home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / doloop / ISTCD.MAC.f < prev    next >
Encoding:
Text File  |  1989-03-04  |  127.8 KB  |  4,055 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 2.1
  3. C---------------------------------------------------------
  4. C
  5. C    - REMOVE TABS
  6. C    - PROGRAM UNITS RE-ORDERED
  7. C    - ADDITIONAL YADEFS INCLUSIONS REMOVED
  8. C    - DEFINES MOVED
  9. C    - UNSPLIT LINES REMOVED
  10. C    - CHANGE ZCTYPE TO ZPTYPE
  11. C    - USE NEW TOKEN WRITE ROUTINE, CHANGE IODTKO/IODCMO FOR
  12. C      TKNCHN AND USE ZTKPTI AS AN INITIALISATION CALL.
  13. C    - REMOVE USE OF IODCMT FOR TOKEN OUTPUT
  14. C    - CHANGE CLAB AND GETIL TO SELECT UNIQUE NUMBERS/LABELS AND
  15. C      REMOVE THE NEED FOR THE SCRATCH FILE......
  16. C    - CHANGE COMMON BLOCK /IO/
  17. C
  18. C---------------------------------------------------------
  19. C    TOOLPACK/1    Release: 2.1
  20. C---------------------------------------------------------
  21. C---------------------------------------------------------
  22. C    TOOLPACK/1    Release: 2.1
  23. C---------------------------------------------------------
  24. C---------------------------------------------------------
  25. C    TOOLPACK/1    Release: 2.1
  26. C---------------------------------------------------------
  27.  
  28.  
  29.  
  30.  
  31.  
  32.  
  33.  
  34.  
  35. C                                   parameter length
  36.  
  37.  
  38.  
  39.  
  40.  
  41.  
  42.  
  43.  
  44.  
  45. C following are for ZYCSDT (Canonicalise Symbol Data Types)
  46. C
  47.       PROGRAM ISTCD
  48.  
  49.       COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  50.       INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  51.  
  52. C---------------------------------------------------------
  53. C    TOOLPACK/1    Release: 2.1
  54. C---------------------------------------------------------
  55. C
  56. C THIS IS USED BY BOTH ISTSB AND ISTCD
  57. C
  58. C This COMMON block contains the logical variable ITERAT which is
  59. C set to .TRUE. when a condition is encountered that implies that
  60. C further processing is required on the parse tree obtained from
  61. C the token stream output from the current run.  ZQUIT is called
  62. C with condition 'repeat' if and only if ITERAT is .TRUE.
  63. C
  64. C This COMMON block contains the logical variables ITERAT and CYCLE.
  65.  
  66.       COMMON /REPEAT/ ITERAT,CYCLE
  67.       LOGICAL ITERAT,CYCLE
  68.  
  69.       INTEGER TKNPTH(81),CIPTH(81),
  70.      +        TKOPTH(81),CMOPTH(81),CMTPTH(81),
  71.      +        NERROR,NWARN
  72.  
  73.       INTEGER OPEN,CREATE,GETARG,ZGTCMD,CTOI,ZYINCI,YPARSE
  74.       EXTERNAL OPEN,CREATE,ERROR,ZINIT,ZQUIT,ZMESS,
  75.      +           GETARG,ZGTCMD,CTOI,ZPTINT,SEEK,PUTCH,YPARSE
  76.  
  77.       SAVE
  78.  
  79.         DATA (CIPTH(I),I=1,10)/35,
  80.      +99,100,99,109,105,116,109,112,129/
  81.  
  82.       CALL ZINIT
  83.  
  84.       IF (GETARG(1,TKNPTH,81).EQ.-100) CALL NAMES(1,TKNPTH)
  85.       IF (GETARG(2,CMTPTH,81).EQ.-100) CALL NAMES(2,CMTPTH)
  86.       IF (GETARG(3,TKOPTH,81).EQ.-100) CALL NAMES(3,TKOPTH)
  87.       IF (GETARG(4,CMOPTH,81).EQ.-100) CALL NAMES(4,CMOPTH)
  88.  
  89.       IODCMI = CREATE(CIPTH,2)
  90.       IF (IODCMI.EQ.-1) CALL ERROR('Can''t create scratch file.')
  91.  
  92.       IODTKN=OPEN(TKNPTH,0)
  93.       IF (IODTKN.EQ.-1) CALL ERROR('Can''t open token stream.')
  94.       IODCMT=OPEN(CMTPTH,0)
  95.       IF (IODCMT.EQ.-1) CALL ERROR('Can''t open comment file.')
  96.       IODTKO=CREATE(TKOPTH,1)
  97.       IF (IODTKO.EQ.-1) CALL ERROR('Can''t create token stream.')
  98.       IODCMO=CREATE(CMOPTH,1)
  99.       IF (IODCMO.EQ.-1) CALL ERROR('Can''t create comment stream.')
  100.  
  101.       CALL INISTR
  102.       CALL INISYM
  103.       CALL INITRE
  104.       NERROR = 0
  105.       NWARN = 0
  106.       IF(YPARSE(IODTKN,IODCMT,-1,IODCMI,NERROR,NWARN).NE.0) THEN
  107.         CALL ERROR('[ISTCD - PARSER FATAL ERROR].')
  108.       ENDIF
  109.       IF(NERROR .GT. 0) THEN
  110.         CALL ERROR('[ISTCD - PARSER ERRORS REPORTED].')
  111.       ENDIF
  112.  
  113.       CALL SEEK(0, IODCMI)
  114.       CALL SEEK(0, IODCMT)
  115.       IF(ZYINCI(IODCMI) .EQ. -1) CALL ERROR('[ISTCD - ZYINCI ERROR].')
  116.  
  117. C Initialize ITERAT and CYCLE (in COMMON block REPEAT).
  118.       ITERAT = .FALSE.
  119.       CYCLE = .FALSE.
  120.  
  121.       CALL PROFIL
  122.  
  123. C CYCLE takes precedence over ITERAT.
  124.       IF (CYCLE) THEN
  125.          CALL ZMESS('[ISTCD Normal Termination].',2)
  126.          CALL ZMESS('[ ** Cycle ISTSB/ISTCD ** ].',2)
  127.          CALL ZQUIT(-2001)
  128.       ELSE IF (ITERAT) THEN
  129.          CALL ZMESS('[ISTCD Normal Termination].',2)
  130.          CALL ZMESS('[ ** Repeat ISTCD ** ].',2)
  131.          CALL ZQUIT(-2000)
  132.       ELSE
  133.          CALL ZMESS('[ISTCD Normal Termination].',2)
  134.          CALL ZQUIT(-2)
  135.       END IF
  136.  
  137.       END
  138. C ----------------------------------------------------------------------
  139. C
  140.       SUBROUTINE NAMES (NUMBER,PATH)
  141.  
  142.       INTEGER NUMBER,PATH(81)
  143.  
  144.       INTEGER ZGTCMD
  145.       EXTERNAL ZGTCMD,ZPRMPT
  146.  
  147.       INTEGER JUNK,PROMPT(24,4)
  148.  
  149.       SAVE PROMPT
  150.  
  151. C "Input token stream:"
  152. C "Input comment stream: "
  153. C "Output token stream: "
  154. C "Output comment stream: "
  155.  
  156.       DATA (PROMPT(I,1),I=1,21)/73,110,112,117,116,32,116,
  157.      +111,107,101,110,32,115,116,114,101,97,109,
  158.      +58,32,129/,
  159.      +       (PROMPT(I,2),I=1,23)/73,110,112,117,116,32,99,
  160.      +111,109,109,101,110,116,32,115,116,114,101,97,109,
  161.      +58,32,129/,
  162.      +       (PROMPT(I,3),I=1,22)/79,117,116,112,117,116,32,
  163.      +116,111,107,101,110,32,115,116,114,101,97,109,
  164.      +58,32,129/,
  165.      +       (PROMPT(I,4),I=1,24)/79,117,116,112,117,116,32,
  166.      +99,111,109,109,101,110,116,32,115,116,114,101,97,
  167.      +109,58,32,129/
  168.  
  169.       CALL ZPRMPT(PROMPT(1,NUMBER))
  170.       JUNK=ZGTCMD(PATH,0)
  171.  
  172.       END
  173. C ----------------------------------------------------------------------
  174. C
  175. C       P R O F I L   -   Process files
  176. C
  177.  
  178.       SUBROUTINE PROFIL
  179.  
  180.       COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  181.       INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  182.  
  183. C---------------------------------------------------------
  184. C    TOOLPACK/1    Release: 2.1
  185. C---------------------------------------------------------
  186. C
  187. C THIS IS USED BY BOTH ISTSB AND ISTCD
  188. C
  189. C This COMMON block contains the logical variable ITERAT which is
  190. C set to .TRUE. when a condition is encountered that implies that
  191. C further processing is required on the parse tree obtained from
  192. C the token stream output from the current run.  ZQUIT is called
  193. C with condition 'repeat' if and only if ITERAT is .TRUE.
  194. C
  195. C This COMMON block contains the logical variables ITERAT and CYCLE.
  196.  
  197.       COMMON /REPEAT/ ITERAT,CYCLE
  198.       LOGICAL ITERAT,CYCLE
  199. C---------------------------------------------------------
  200. C    TOOLPACK/1    Release: 2.1
  201. C---------------------------------------------------------
  202. C
  203. C  TKLAST = LAST TOKEN NUMBER
  204. C
  205.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  206.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  207.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  208.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  209.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  210.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  211.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  212.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  213.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  214.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  215.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  216.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  217.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  218.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  219.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  220.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  221.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  222.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  223.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  224.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  225.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  226.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  227.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  228.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  229.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  230.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  231.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  232.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  233.  
  234.  
  235.       COMMON /CLAB/ CURLBL,CURPUN,FIRST
  236.       LOGICAL FIRST
  237.       INTEGER CURLBL,CURPUN
  238.       INTEGER TEXT(134), SYMVAL(8)
  239.  
  240.       INTEGER PTR
  241.       INTEGER ZYDOWN,ZYNEXT,ZYROOT,ZTKPTI,ZYGPUS
  242.       EXTERNAL ZYDOWN,ZYNEXT,ZYROOT,ZTOKWR,ZTKPTI
  243.  
  244.       SAVE
  245.  
  246.       TKNCHN = ZTKPTI(1, IODTKO, IODCMO)
  247.       IF(TKNCHN .EQ. -1) CALL ERROR('[ISTCD - Output Stream Failure].')
  248.  
  249.       PTR=ZYDOWN(ZYROOT())
  250.       CURPUN = 0
  251.  
  252.  100  IF (PTR.GT.0) THEN
  253.          CURLBL = 59999
  254.          CURPUN = CURPUN + 1
  255.          FIRST = .TRUE.
  256.          CALL ZYGTSY(ZYGPUS(CURPUN), SYMVAL)
  257.          CALL ZYGTST(SYMVAL(2), TEXT)
  258.          CALL ZCHOUT('CD Processing: ', 2)
  259.          CALL ZPTMES(TEXT, 2)
  260.          CALL PROPU(PTR)
  261.          PTR=ZYNEXT(PTR)
  262.          GO TO 100
  263.       END IF
  264.       CALL ZTOKWR(TZEOF,0,TEXT,TKNCHN)
  265.  
  266.       END
  267. C-----------------------   CHKDOP.MAC
  268. C ---------------------------------------------------------------------
  269. C        C H K D O P - Check three conditions associated with Paradigm PEQ.
  270. C                      Output comment(s), through calls to COMDEP when
  271. C                      conditions are violated and return 'no'. If conditions
  272. C                     are satisfied, return 'yes' and a comment referring
  273. C                      to the user's guide.
  274. C
  275. C The conditions are:
  276. C   (1) Every statement in the range of every DO is an assignment.
  277. C
  278. C   (2) The lhs of every statement in the range of every DO is an
  279. C       array element with one subscript which is the (common) DO
  280. C       variable.  (Let LHSARN contain the set of names of arrays that
  281. C       appear on the lhs of statements in the ranges of the DOs.)
  282. C
  283. C   (3) In every appearance on the rhs of any statement in any DO of an
  284. C       array named in LHSARN, each subscript is of form N+C or N-C where
  285. C       N is a name and C is a constant integer .ge. 0.  If C > 0, then
  286. C       N is NOT the DO variable.
  287.  
  288.        INTEGER FUNCTION CHKDOP(VAR,FIRST,LAST,NRDOS)
  289.  
  290.        INTEGER VAR(*),FIRST(*),LAST(*),NRDOS
  291.  
  292.       COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  293.       INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  294.  
  295.        INTEGER SPTR,LHSNOD,INDNAM(7),LHSARN(7,200),NRARN,
  296.      +          ARNAM(7),INDPTR,NAMNOD,NPIPTR,POINTR,RHSNOD,
  297.      +          STACK(500),TYPE,JUNK(7),JSTR1(7),
  298.      +          CSTR1(7),PLUS, I, J
  299.  
  300.        INTEGER NODETP,ZYDOWN,ZYNEXT,EQUAL,POP,PUSH,JPMC
  301.        SAVE
  302.        EXTERNAL NODETP,ZYDOWN,ZYNEXT,GETSTR,EQUAL,POP,PUSH,
  303.      +           COMDEP,JPMC
  304.  
  305.        CHKDOP = -2
  306.        NRARN = 0
  307.        STACK(1) = -1
  308.  
  309. C Check conditions PEQ-A and PEQ-B.
  310.        DO 10 I = 1,NRDOS
  311.           SPTR = FIRST(I)
  312. 40          CONTINUE
  313. C Is statement an assignment?
  314.           IF (NODETP(SPTR) .NE. 49) THEN
  315.              CALL COMDEP(2,JUNK)
  316.              CHKDOP = -3
  317.              GO TO 140
  318.           END IF
  319.  
  320. C Is lhs an array element?
  321.           LHSNOD = ZYDOWN(SPTR)
  322.           IF (NODETP(LHSNOD) .EQ. 115) LHSNOD = ZYNEXT(LHSNOD)
  323. C LHSNOD is node of lhs.
  324.           IF (NODETP(LHSNOD) .NE. 104) THEN
  325.              CALL COMDEP(33,JUNK)
  326.              CHKDOP = -3
  327.              GO TO 140
  328.           END IF
  329.  
  330. C Save the name of the array element in LHSARN.
  331. C NRARN the number of names in the set.  Names may be duplicates.
  332.           LHSNOD = ZYDOWN(LHSNOD)
  333. C LHSNOD is now node of array name.
  334.           NRARN = NRARN + 1
  335.           IF (NRARN .GT. 200) CALL ERROR('CHKDOP: Increase Size '//
  336.      +                         'of Array LHSARN.')
  337.           CALL GETSTR(LHSNOD,LHSARN(1,NRARN))
  338.  
  339. C Get subscript - make sure it's a name.
  340.           LHSNOD = ZYNEXT(LHSNOD)
  341. 60          CONTINUE
  342.           IF (NODETP(LHSNOD) .EQ. 101) THEN
  343.              LHSNOD = ZYDOWN(LHSNOD)
  344.              GO TO 60
  345.           END IF
  346. C LHSNOD is now node of subscript.
  347.  
  348.           IF (NODETP(LHSNOD) .NE. 108) THEN
  349.              CALL COMDEP(3,LHSARN(1,NRARN))
  350.              CHKDOP = -3
  351.              GO TO 140
  352.           END IF
  353.  
  354. C Is subscript the DO variable?
  355.           CALL GETSTR(LHSNOD,INDNAM)
  356.           IF (EQUAL(INDNAM,VAR) .NE. -2) THEN
  357.               CALL COMDEP(3,LHSARN(1,NRARN))
  358.              CHKDOP = -3
  359.           END IF
  360.  
  361.           LHSNOD = ZYNEXT(LHSNOD)
  362. C Is there another subscript?
  363.           IF (LHSNOD .NE. 0) THEN
  364.               CALL COMDEP(3,LHSARN(1,NRARN))
  365.              CHKDOP = -3
  366.           END IF
  367.  
  368. 140          CONTINUE
  369.           IF (SPTR .NE. LAST(I)) THEN
  370.              SPTR = ZYNEXT(SPTR)
  371.              GO TO 40
  372.           END IF
  373.  
  374. 10       CONTINUE
  375.  
  376. C Check condition PEQ-C.
  377.        DO 100 I = 1,NRDOS
  378.           SPTR = FIRST(I)
  379. 120          CONTINUE
  380.  
  381. C Get node of rhs.
  382.           RHSNOD = ZYDOWN(SPTR)
  383.           IF (NODETP(RHSNOD) .EQ. 115) RHSNOD = ZYNEXT(RHSNOD)
  384.           RHSNOD = ZYNEXT(RHSNOD)
  385.  
  386.           POINTR = RHSNOD
  387. 70          CONTINUE
  388.             TYPE = NODETP(POINTR)
  389.           IF(TYPE .EQ. 104) THEN
  390.  
  391. C If the name of the array is not in LHSARN continue the search
  392. C of the rhs.
  393.              NAMNOD = ZYDOWN(POINTR)
  394.              CALL GETSTR(NAMNOD,ARNAM)
  395.              DO 80 J=1,NRARN
  396.                 IF (EQUAL(ARNAM,LHSARN(1,J)) .EQ. -2) GO TO 90
  397. 80             CONTINUE
  398.                GO TO 110
  399. 90             CONTINUE
  400. C The name of the array is in LHSARN.
  401.              INDPTR = ZYNEXT(NAMNOD)
  402.  
  403. C INDPTR is the node of an subscript. Remove parentheses.
  404. 50             NPIPTR = INDPTR
  405. 30             CONTINUE
  406.              IF (NODETP(NPIPTR) .EQ. 101) THEN
  407.                 NPIPTR = ZYDOWN(NPIPTR)
  408.                 GO TO 30
  409.              END IF
  410.  
  411. C NPIPTR is the node of the subscript with parentheses removed.
  412.              IF (JPMC(NPIPTR,JSTR1,CSTR1,PLUS) .EQ. -3) THEN
  413.                 CALL COMDEP(4,ARNAM)
  414.                 CHKDOP = -3
  415.              END IF
  416.  
  417. C Subscript is of form N, N+C, or N-C.  In the latter two cases,
  418. C N cannot be the DO variable.
  419.              IF (PLUS .NE. 0) THEN
  420.                 IF (EQUAL(JSTR1,VAR) .EQ. -2) THEN
  421.                    CALL COMDEP(4,ARNAM)
  422.                    CHKDOP = -3
  423.                 END IF
  424.              END IF
  425.  
  426.              INDPTR = ZYNEXT(INDPTR)
  427. C Is there another subscript?
  428.              IF (INDPTR .NE. 0) GO TO 50
  429.           END IF
  430. 110          CONTINUE
  431.           IF(PUSH(POINTR,STACK) .EQ. -1)CALL ERROR('Stack Full.',2)
  432.           POINTR = ZYDOWN(POINTR)
  433. C If POINTR > 0, node is not a leaf.
  434.           IF(POINTR .GT. 0) GO TO 70
  435. C Node is a leaf.
  436. C Can't go down, try next unless we are at RHSNOD.
  437.           POINTR = POP(STACK)
  438.           IF(POINTR .EQ. RHSNOD) GO TO 130
  439.  
  440.           POINTR = ZYNEXT(POINTR)
  441.           IF(POINTR .GT. 0) GO TO 70
  442. C Can't go next, pop until next is possible or return to RHSNOD is complete.
  443.             POINTR = POP(STACK)
  444.           IF(POINTR .EQ. -1 .OR. POINTR .EQ. RHSNOD) GO TO 130
  445. 20          CONTINUE
  446.           POINTR = ZYNEXT(POINTR)
  447.           IF(POINTR .GT. 0) THEN
  448.              GO TO 70
  449.           ELSE
  450.              POINTR = POP(STACK)
  451.              IF(POINTR .EQ. -1 .OR. POINTR .EQ. RHSNOD) GO TO 130
  452.              GO TO 20
  453.           END IF
  454.  
  455. 130          CONTINUE
  456.           IF (SPTR .NE. LAST(I)) THEN
  457.              SPTR = ZYNEXT(SPTR)
  458.              GO TO 120
  459.           END IF
  460. 100       CONTINUE
  461.  
  462.        IF (CHKDOP .EQ. -2) CALL COMDEP(5,JUNK)
  463.        CALL COMDEP(1,JUNK)
  464.  
  465.        END
  466. C-----------------------   CHKEQV.MAC
  467. C ---------------------------------------------------------------------
  468. C        C H K E Q V - Check equivalence of parameters E1,E2
  469. C                      in a DO sequence.
  470. C
  471.       SUBROUTINE CHKEQV(E1,E2,SEQLEN,E1SAME,E2SAME)
  472. C If the first SEQLEN of the E1 parameters are equivalent, return
  473. C E1SAME = .TRUE., otherwise, E1SAME = .FALSE. Similarly for the E2
  474. C parameters and E2SAME.  Parentheses are removed for comparison.
  475.  
  476.       INTEGER E1(*),E2(*),SEQLEN
  477.       LOGICAL E1SAME,E2SAME
  478.  
  479.       INTEGER NPE1(50),NPE2(50), I
  480.       INTEGER COMPAR,NODETP,ZYDOWN
  481.       EXTERNAL COMPAR,NODETP,ZYDOWN
  482.  
  483.       E1SAME = .FALSE.
  484.       E2SAME = .FALSE.
  485.  
  486. C Remove parentheses for comparison.
  487.       DO 5 I = 1,SEQLEN
  488.          NPE1(I) = E1(I)
  489. 70         CONTINUE
  490.          IF (NODETP(NPE1(I)) .EQ. 101) THEN
  491.             NPE1(I) = ZYDOWN(NPE1(I))
  492.             GO TO 70
  493.          END IF
  494.          NPE2(I) = E2(I)
  495. 80         CONTINUE
  496.          IF (NODETP(NPE2(I)) .EQ. 101) THEN
  497.             NPE2(I) = ZYDOWN(NPE2(I))
  498.             GO TO 80
  499.          END IF
  500. 5      CONTINUE
  501.  
  502.       DO 10 I=2,SEQLEN
  503.          IF (COMPAR(NPE1(1),NPE1(I)) .EQ. -3) GO TO 100
  504. 10      CONTINUE
  505.       E1SAME = .TRUE.
  506.  
  507. 100      CONTINUE
  508.       DO 20 I=2,SEQLEN
  509.          IF (COMPAR(NPE2(1),NPE2(I)) .EQ. -3) GO TO 200
  510. 20      CONTINUE
  511.       E2SAME = .TRUE.
  512.  
  513. 200   CONTINUE
  514.       END
  515. C-----------------------   CHKIND.MAC
  516. C   I N D J P 1
  517. C
  518.        INTEGER FUNCTION INDJP1(NODE,NAME,CONST)
  519. C Return 'yes' or 'no' according to whether, in the subtree rooted
  520. C at NODE, every index of every array element is of form NAME or
  521. C NAME + KON where val(KON) is any of val(CONST),val(CONST)-1,...,1.
  522. C (KON and CONST are represented as strings.)
  523.  
  524.       COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  525.       INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  526.  
  527.       INTEGER NODE,NAME(*),CONST(*),POINTR,TYPE,INDPTR,NPIPTR,
  528.      +          STACK(500),KON(4),
  529.      +          NUM1,VALKON,VALCNS,JSTR(10),PLUS,JPMC
  530.  
  531.       INTEGER ZYROOT, NODETP, ZYDOWN, ZYNEXT, ZYUP, PUSH, POP,
  532.      +          EQUAL,CTOI
  533.       SAVE
  534.       EXTERNAL ZYINPT, ZYROOT, ZPTINT, NODETP, ZYDOWN, ZCHOUT,
  535.      +           ZYNEXT, ZYUP, PUSH, POP, ZYGTSY,
  536.      +           ZYGTST, ZPTMES, EQUAL, SCOPY, GETSTR,CTOI
  537.  
  538.       STACK(1) = -1
  539.  
  540.       POINTR = NODE
  541.    10 CONTINUE
  542.         TYPE = NODETP(POINTR)
  543.         IF(TYPE .EQ. 104) THEN
  544.           INDPTR = ZYNEXT(ZYDOWN(POINTR))
  545. C INDPTR is the node of an index. Remove parentheses.
  546. 50          NPIPTR = INDPTR
  547. 30          CONTINUE
  548.           IF (NODETP(NPIPTR) .EQ. 101) THEN
  549.              NPIPTR = ZYDOWN(NPIPTR)
  550.              GO TO 30
  551.           END IF
  552.  
  553.           IF (JPMC(NPIPTR,JSTR,KON,PLUS) .EQ. -3) THEN
  554.              INDJP1 = -3
  555.              RETURN
  556.           END IF
  557.  
  558. C The index is of form J, J+c, or J-c.
  559.           IF (PLUS .EQ. -1) THEN
  560.              INDJP1 = -3
  561.              RETURN
  562.           END IF
  563.  
  564. C The index is of form  J or J + c.  Is J = NAME?
  565.           IF (EQUAL(JSTR,NAME) .EQ. -3) THEN
  566.              INDJP1 = -3
  567.              RETURN
  568.           END IF
  569.  
  570.           IF (PLUS .EQ. 0) GO TO 40
  571.  
  572. C The index is of form J + c.  Is c = CONST or CONST-1 or ... or 1?
  573.           NUM1 = 1
  574.           VALKON = CTOI(KON,NUM1)
  575.           NUM1 = 1
  576.           VALCNS = CTOI(CONST,NUM1)
  577.           IF ((VALKON .GT. VALCNS) .OR. (VALKON .LT. 1)) THEN
  578.              INDJP1 = -3
  579.              RETURN
  580.           END IF
  581.  
  582. 40        CONTINUE
  583.  
  584. C The index is of form NAME + KON.  Go on to the next index.
  585.           INDPTR = ZYNEXT(INDPTR)
  586.           IF (INDPTR .GT. 0) GO TO 50
  587.        END IF
  588.        IF(PUSH(POINTR,STACK) .EQ. -1)CALL ERROR('Stack Full.',2)
  589.        POINTR = ZYDOWN(POINTR)
  590. C If POINTR > 0, node is not a leaf.
  591.        IF(POINTR .GT. 0) GO TO 10
  592. C Node is a leaf.
  593. C Can't go down, try next unless we are at NODE.
  594.        POINTR = POP(STACK)
  595.        IF(POINTR .EQ. NODE) THEN
  596.           INDJP1 = -2
  597.           RETURN
  598.        END IF
  599.        POINTR = ZYNEXT(POINTR)
  600.        IF(POINTR .GT. 0) GO TO 10
  601. C Can't go next, pop until next is possible or return to NODE is complete.
  602.          POINTR = POP(STACK)
  603.        IF(POINTR .EQ. -1 .OR. POINTR .EQ. NODE) THEN
  604.           INDJP1 = -2
  605.           RETURN
  606.        END IF
  607. 20       CONTINUE
  608.        POINTR = ZYNEXT(POINTR)
  609.        IF(POINTR .GT. 0) THEN
  610.           GO TO 10
  611.        ELSE
  612.           POINTR = POP(STACK)
  613.           IF(POINTR .EQ. -1 .OR. POINTR .EQ. NODE) THEN
  614.              INDJP1 = -2
  615.              RETURN
  616.           END IF
  617.           GO TO 20
  618.       END IF
  619.       END
  620. C---------------------------------------------------------------
  621. C   I N D J M 1
  622. C
  623.       INTEGER FUNCTION INDJM1(NODE,NAME,CONST,JM0)
  624. C Return 'yes' or 'no' according to whether, in the subtree rooted
  625. C at NODE, every index of every array element is of form NAME or
  626. C NAME - KON where val(KON) is any of val(CONST),val(CONST)-1,...,1.
  627. C (KON and CONST are represented as strings.) If any index is of the
  628. C form NAME, then return JM0 as .TRUE., otherwise JM0 is returned
  629. C as .FALSE.
  630.  
  631.       COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  632.       INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  633.  
  634.       INTEGER NODE,NAME(*),CONST(*),POINTR,TYPE,INDPTR,NPIPTR,
  635.      +          STACK(500),KON(4),
  636.      +          NUM1,VALKON,VALCNS,JSTR(10),PLUS,JPMC
  637.  
  638.       LOGICAL JM0
  639.       SAVE
  640.       INTEGER ZYROOT, NODETP, ZYDOWN, ZYNEXT, ZYUP, PUSH, POP,
  641.      +          EQUAL,CTOI
  642.  
  643.       EXTERNAL ZYINPT, ZYROOT, ZPTINT, NODETP, ZYDOWN, ZCHOUT,
  644.      +           ZYNEXT, ZYUP, PUSH, POP, ZYGTSY,
  645.      +           ZYGTST, ZPTMES, EQUAL, SCOPY, GETSTR,CTOI
  646.  
  647.       STACK(1) = -1
  648.       JM0 = .FALSE.
  649.  
  650.       POINTR = NODE
  651. 10    CONTINUE
  652.       TYPE = NODETP(POINTR)
  653.       IF(TYPE .EQ. 104) THEN
  654.         INDPTR = ZYNEXT(ZYDOWN(POINTR))
  655. C INDPTR is the node of an index. Remove parentheses.
  656. 50      NPIPTR = INDPTR
  657. 30      CONTINUE
  658.           IF (NODETP(NPIPTR) .EQ. 101) THEN
  659.              NPIPTR = ZYDOWN(NPIPTR)
  660.              GO TO 30
  661.           END IF
  662.  
  663.           IF (JPMC(NPIPTR,JSTR,KON,PLUS) .EQ. -3) THEN
  664.              INDJM1 = -3
  665.              RETURN
  666.           END IF
  667.  
  668. C The index is of form J, J+c, or J-c.
  669.           IF (PLUS .EQ. 1) THEN
  670.              INDJM1 = -3
  671.              RETURN
  672.           END IF
  673.  
  674. C The index is of form J or J - c.  Is J = NAME?
  675.           IF (EQUAL(JSTR,NAME) .EQ. -3) THEN
  676.              INDJM1 = -3
  677.              RETURN
  678.           END IF
  679.  
  680.           IF (PLUS .EQ. 0) THEN
  681.              JM0 = .TRUE.
  682.              GO TO 40
  683.           END IF
  684.  
  685. C The index is of form J - c.  Is c = CONST or CONST-1 or ... or 1?
  686.           NUM1 = 1
  687.           VALKON = CTOI(KON,NUM1)
  688.           NUM1 = 1
  689.           VALCNS = CTOI(CONST,NUM1)
  690.           IF ((VALKON .GT. VALCNS) .OR. (VALKON .LT. 1)) THEN
  691.              INDJM1 = -3
  692.              RETURN
  693.           END IF
  694.  
  695. 40          CONTINUE
  696.  
  697. C The index is of form NAME - KON.  Go on to the next index.
  698.           INDPTR = ZYNEXT(INDPTR)
  699.           IF (INDPTR .GT. 0) GO TO 50
  700.        END IF
  701.        IF(PUSH(POINTR,STACK) .EQ. -1)CALL ERROR('Stack Full.',2)
  702.        POINTR = ZYDOWN(POINTR)
  703. C If POINTR > 0, node is not a leaf.
  704.        IF(POINTR .GT. 0) GO TO 10
  705. C Node is a leaf.
  706. C Can't go down, try next unless we are at NODE.
  707.        POINTR = POP(STACK)
  708.        IF(POINTR .EQ. NODE) THEN
  709.           INDJM1 = -2
  710.           RETURN
  711.        END IF
  712.        POINTR = ZYNEXT(POINTR)
  713.        IF(POINTR .GT. 0) GO TO 10
  714. C Can't go next, pop until next is possible or return to NODE is complete.
  715.          POINTR = POP(STACK)
  716.        IF(POINTR .EQ. -1 .OR. POINTR .EQ. NODE) THEN
  717.           INDJM1 = -2
  718.           RETURN
  719.        END IF
  720. 20       CONTINUE
  721.        POINTR = ZYNEXT(POINTR)
  722.        IF(POINTR .GT. 0) THEN
  723.           GO TO 10
  724.        ELSE
  725.           POINTR = POP(STACK)
  726.           IF(POINTR .EQ. -1 .OR. POINTR .EQ. NODE) THEN
  727.              INDJM1 = -2
  728.              RETURN
  729.           END IF
  730.           GO TO 20
  731.        END IF
  732.        END
  733. C -----------------------------------------------------------------
  734. C   I N D J P K
  735. C
  736.       INTEGER FUNCTION INDJPK(NODE,NAME)
  737. C Return 'yes' or 'no' according to whether, in the subtree rooted
  738. C at NODE, every index of every array element is of form NAME or
  739. C NAME + KON where val(KON) .gt. 0.
  740.  
  741.       COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  742.       INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  743.  
  744.       INTEGER NODE,NAME(*), JPMC
  745.       SAVE
  746.       INTEGER POINTR,TYPE,INDPTR,NPIPTR,STACK(500),KON(4),
  747.      +          JSTR(10),PLUS
  748.  
  749.        INTEGER ZYROOT, NODETP, ZYDOWN, ZYNEXT, ZYUP, PUSH, POP,
  750.      +          EQUAL,CTOI
  751.  
  752.        EXTERNAL ZYINPT, ZYROOT, ZPTINT, NODETP, ZYDOWN, ZCHOUT,
  753.      +           ZYNEXT, ZYUP, PUSH, POP, ZYGTSY,
  754.      +           ZYGTST, ZPTMES, EQUAL, SCOPY, GETSTR,CTOI
  755.  
  756.        STACK(1) = -1
  757.  
  758.        POINTR = NODE
  759. 10       CONTINUE
  760.        TYPE = NODETP(POINTR)
  761.        IF(TYPE .EQ. 104) THEN
  762.           INDPTR = ZYNEXT(ZYDOWN(POINTR))
  763. C INDPTR is the node of an index. Remove parentheses.
  764. 50          NPIPTR = INDPTR
  765. 30          CONTINUE
  766.           IF (NODETP(NPIPTR) .EQ. 101) THEN
  767.              NPIPTR = ZYDOWN(NPIPTR)
  768.              GO TO 30
  769.           END IF
  770.  
  771.           IF (JPMC(NPIPTR,JSTR,KON,PLUS) .EQ. -3) THEN
  772.              INDJPK = -3
  773.              RETURN
  774.           END IF
  775.  
  776. C The index is of form J, J+c, or J-c.
  777.           IF (PLUS .EQ. -1) THEN
  778.              INDJPK = -3
  779.              RETURN
  780.           END IF
  781.  
  782. C The index is of form J or J + c.  Is J = NAME?
  783.           IF (EQUAL(JSTR,NAME) .EQ. -3) THEN
  784.              INDJPK = -3
  785.              RETURN
  786.           END IF
  787.  
  788. C The index is of form NAME + KON.  Go on to the next index.
  789.           INDPTR = ZYNEXT(INDPTR)
  790.           IF (INDPTR .GT. 0) GO TO 50
  791.        END IF
  792.        IF(PUSH(POINTR,STACK) .EQ. -1)CALL ERROR('Stack Full.',2)
  793.        POINTR = ZYDOWN(POINTR)
  794. C If POINTR > 0, node is not a leaf.
  795.        IF(POINTR .GT. 0) GO TO 10
  796. C Node is a leaf.
  797. C Can't go down, try next unless we are at NODE.
  798.        POINTR = POP(STACK)
  799.        IF(POINTR .EQ. NODE) THEN
  800.           INDJPK = -2
  801.           RETURN
  802.        END IF
  803.        POINTR = ZYNEXT(POINTR)
  804.        IF(POINTR .GT. 0) GO TO 10
  805. C Can't go next, pop until next is possible or return to NODE is complete.
  806.          POINTR = POP(STACK)
  807.        IF(POINTR .EQ. -1 .OR. POINTR .EQ. NODE) THEN
  808.           INDJPK = -2
  809.           RETURN
  810.        END IF
  811. 20       CONTINUE
  812.        POINTR = ZYNEXT(POINTR)
  813.        IF(POINTR .GT. 0) THEN
  814.           GO TO 10
  815.        ELSE
  816.           POINTR = POP(STACK)
  817.           IF(POINTR .EQ. -1 .OR. POINTR .EQ. NODE) THEN
  818.              INDJPK = -2
  819.              RETURN
  820.           END IF
  821.           GO TO 20
  822.        END IF
  823.        END
  824. C-----------------------   COMDEP.MAC
  825. C ---------------------------------------------------------------
  826. C      C O M D E P - Output comments about violation of the
  827. C                    permutability condition checked by CHKDOP.
  828. C
  829. C For any value of NUM output comment:
  830. C "C *** See ISTCD Documentation For Definition Of PEQ Conditions ***"
  831. C (only one such comment per DO sequence)
  832. C
  833. C If NUM = 1, reset PRNTED to .FALSE.
  834. C
  835. C If NUM = 2, output comment:
  836. C "C     >>> Condition PEQ-A fails <<<"
  837. C
  838. C If NUM = 3, output comment:
  839. C "C     >>> Condition PEQ-B fails for array [NAME] <<<"
  840. C
  841. C If NUM = 33, output comment:
  842. C "C     >>> Condition PEQ-B fails <<<"
  843. C
  844. C If NUM = 4, output comment:
  845. C "C     >>> Condition PEQ-C fails for array [NAME] <<<"
  846. C
  847. C If NUM = 5, output comment:
  848. C "C *** PEQ conditions are satisfied ***"
  849.  
  850.        SUBROUTINE COMDEP(NUM,NAME)
  851.  
  852.        INTEGER NUM,NAME(7)
  853.        LOGICAL PRNTED
  854.  
  855.       COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  856.       INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  857.  
  858. C---------------------------------------------------------
  859. C    TOOLPACK/1    Release: 2.1
  860. C---------------------------------------------------------
  861. C
  862. C  TKLAST = LAST TOKEN NUMBER
  863. C
  864.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  865.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  866.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  867.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  868.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  869.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  870.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  871.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  872.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  873.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  874.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  875.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  876.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  877.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  878.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  879.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  880.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  881.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  882.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  883.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  884.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  885.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  886.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  887.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  888.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  889.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  890.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  891.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  892.  
  893.  
  894.        INTEGER COM1(66),COM2(35),COM3(52),COM33(35),
  895.      +          COM4(52),COM5(38)
  896.  
  897.        INTEGER LENGTH, JJ
  898.  
  899.        EXTERNAL LENGTH,ZTOKWR
  900.  
  901.        SAVE
  902. C "C *** See ISTCD documentation for definition of PEQ conditions ***"
  903.        DATA COM1/67,42,42,42,32,
  904.      +            83,101,101,32,73,83,84,67,68,
  905.      +            32,100,111,99,117,109,101,110,116,97,
  906.      +            116,105,111,110,32,102,111,114,32,
  907.      +            100,101,102,105,110,105,116,105,111,110,
  908.      +            32,111,102,32,80,69,81,32,99,
  909.      +            111,110,100,105,116,105,111,110,115,
  910.      +            32,42,42,42,129/
  911.  
  912. C "C     >>> Condition PEQ-A fails <<<"
  913.        DATA COM2/67,
  914.      +        32,32,32,32,62,62,62,32,
  915.      +        67,111,110,100,105,116,105,111,110,32,
  916.      +        80,69,81,45,65,32,102,97,105,108,
  917.      +        115,32,60,60,60,129/
  918.  
  919. C "C     >>> Condition PEQ-B fails for array "
  920.        DATA (COM3(JJ),JJ=1,41)/67,
  921.      +        32,32,32,32,62,62,62,32,
  922.      +        67,111,110,100,105,116,105,111,110,32,
  923.      +        80,69,81,45,66,32,102,97,105,108,
  924.      +        115,32,102,111,114,32,97,114,114,97,121,
  925.      +        32/
  926.  
  927. C "C     >>> Condition PEQ-B fails <<<"
  928.        DATA COM33/67,
  929.      +        32,32,32,32,62,62,62,32,
  930.      +        67,111,110,100,105,116,105,111,110,32,
  931.      +        80,69,81,45,66,32,102,97,105,108,
  932.      +        115,32,60,60,60,129/
  933.  
  934. C "C     >>> Condition PEQ-C fails for array "
  935.        DATA (COM4(JJ),JJ=1,41)/67,
  936.      +        32,32,32,32,62,62,62,32,
  937.      +        67,111,110,100,105,116,105,111,110,32,
  938.      +        80,69,81,45,67,32,102,97,105,108,
  939.      +        115,32,102,111,114,32,97,114,114,97,121,
  940.      +        32/
  941.  
  942. C "C *** PEQ conditions are satisfied ***"
  943.        DATA COM5/67,42,42,42,32,
  944.      +            80,69,81,32,99,111,110,100,105,
  945.      +            116,105,111,110,115,32,97,114,101,
  946.      +            32,115,97,116,105,115,102,105,101,100,
  947.      +            32,42,42,42,129/
  948.  
  949.        DATA PRNTED /.FALSE./
  950.  
  951.        IF (NUM .EQ. 1) THEN
  952.           PRNTED = .FALSE.
  953.           RETURN
  954.        END IF
  955.  
  956.         IF (.NOT. PRNTED) THEN
  957.             CALL ZTOKWR(TCMMNT,LENGTH(COM1),COM1,TKNCHN)
  958.           PRNTED = .TRUE.
  959.        END IF
  960.  
  961.        IF (NUM .EQ. 2) THEN
  962. C "C     >>> Condition PEQ-A fails <<<"
  963.  
  964.            CALL ZTOKWR(TCMMNT,LENGTH(COM2),COM2,TKNCHN)
  965.  
  966.        ELSE IF (NUM .EQ. 3) THEN
  967. C "C     >>> Condition PEQ-B fails for array [NAME] <<<"
  968. C Fill in array name.
  969.           DO 125 JJ = 1,7
  970.              IF (NAME(JJ) .EQ. 129) GO TO 130
  971.              COM3(JJ+41) = NAME(JJ)
  972. 125          CONTINUE
  973.  
  974. 130          CONTINUE
  975.           COM3(JJ+41) = 32
  976.           COM3(JJ+42) = 60
  977.           COM3(JJ+43) = 60
  978.           COM3(JJ+44) = 60
  979.           COM3(JJ+45) = 129
  980.  
  981.            CALL ZTOKWR(TCMMNT,LENGTH(COM3),COM3,TKNCHN)
  982.  
  983.        ELSE IF (NUM .EQ. 33) THEN
  984. C "C     >>> Condition PEQ-B fails <<<"
  985.  
  986.            CALL ZTOKWR(TCMMNT,LENGTH(COM33),COM33,TKNCHN)
  987.  
  988.        ELSE IF (NUM .EQ. 4) THEN
  989. C "C     >>> Condition PEQ-C fails for array [NAME] <<<"
  990. C Fill in array name.
  991.           DO 225 JJ = 1,7
  992.              IF (NAME(JJ) .EQ. 129) GO TO 230
  993.              COM4(JJ+41) = NAME(JJ)
  994. 225          CONTINUE
  995.  
  996. 230          CONTINUE
  997.           COM4(JJ+41) = 32
  998.           COM4(JJ+42) = 60
  999.           COM4(JJ+43) = 60
  1000.           COM4(JJ+44) = 60
  1001.           COM4(JJ+45) = 129
  1002.  
  1003.            CALL ZTOKWR(TCMMNT,LENGTH(COM4),COM4,TKNCHN)
  1004.  
  1005.        ELSE IF (NUM. EQ. 5) THEN
  1006.  
  1007.            CALL ZTOKWR(TCMMNT,LENGTH(COM5),COM5,TKNCHN)
  1008.  
  1009.        END IF
  1010.  
  1011.        END
  1012. C-----------------------   DOPROP.MAC
  1013. C -------------------------------------------------------------------
  1014. C        D O P R O P - Obtain properties of a DO loop.
  1015. C
  1016.       SUBROUTINE DOPROP(NODE,VAR,E1,E2,E3,FIRST,LAST)
  1017. C Obtain the properties of the DO loop whose DO statement is NODE on C
  1018. C the parse tree.  The loop is assumed to end on a CONTINUE.  Return VAR:
  1019. C the DO variable,E1,E2,E3: the nodes of the three parameter expressions
  1020. C (if E3 is the default, then E3 = 0), FIRST: the node of the first
  1021. C statement in the DO range, LAST: the node of the last statement in the
  1022. C range before the terminating CONTINUE.
  1023.  
  1024.       INTEGER NODE,VAR(7),E1,E2,E3,FIRST,LAST
  1025.  
  1026.         COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  1027.         INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  1028.         SAVE
  1029.       INTEGER SPTR,REFNOD,VARNOD,STLBL(6),TRMLBL(6)
  1030.  
  1031.       INTEGER ZYDOWN,NODETP,ZYNEXT,EQUAL,ZYPREV
  1032.       EXTERNAL ZYDOWN,NODETP,ZYNEXT,EQUAL,GETSTR,ZYPREV
  1033.  
  1034.       IF (NODETP(NODE) .NE. 61) CALL ERROR('ISTCD: Node Is Not'
  1035.      +                              //' a DO Statement.')
  1036.  
  1037. C Get terminating label.
  1038.       REFNOD = ZYDOWN(NODE)
  1039.       IF (NODETP(REFNOD) .EQ. 115) REFNOD = ZYNEXT(REFNOD)
  1040.       CALL GETSTR(REFNOD,TRMLBL)
  1041. C Get DO variable.
  1042.       VARNOD = ZYDOWN(ZYNEXT(REFNOD))
  1043.       CALL GETSTR(VARNOD,VAR)
  1044. C Get parameter nodes.
  1045.       E1 = ZYNEXT(VARNOD)
  1046.       E2 = ZYNEXT(E1)
  1047.       E3 = ZYNEXT(E2)
  1048. C First statement in range.
  1049.       FIRST = ZYNEXT(NODE)
  1050. C Look for last statement.
  1051.       SPTR = FIRST
  1052.  
  1053.   100 CONTINUE
  1054.       REFNOD = ZYDOWN(SPTR)
  1055.       IF(REFNOD .NE. 0) THEN
  1056.         IF (NODETP(REFNOD) .EQ. 115) THEN
  1057.           CALL GETSTR(REFNOD,STLBL)
  1058.           IF (EQUAL(STLBL,TRMLBL) .EQ. -2) THEN
  1059. C Terminating CONTINUE found.
  1060.             LAST = ZYPREV(SPTR)
  1061.             RETURN
  1062.           END IF
  1063.         END IF
  1064.       END IF
  1065.  
  1066.       SPTR = ZYNEXT(SPTR)
  1067.       GO TO 100
  1068.  
  1069.       END
  1070. C-----------------------   E3EQV.MAC
  1071. C ------------------------------------------------------------------
  1072. C            E 3 E Q V - Test E3-equivalence
  1073. C
  1074.       INTEGER FUNCTION E3EQV(DONOD,E3NOD,VAR)
  1075. C If the DO statement whose node is DONOD has an E3 node
  1076. C (incrementation parameter) that is equivalent to E3NOD, and if its DO
  1077. C variable is VAR, return 'yes', otherwise return 'no'.  "Equivalence"
  1078. C means either that both incrementation parameters are default, in which
  1079. C case the "nodes" have the value 0, or that the subtrees rooted at the
  1080. C nodes are identical.  Parenthesis are removed from E3 nodes when comparing.
  1081. C
  1082. C  MODIFY TO HANDLE NODE POINTER=0 CASE PROPERLY
  1083. C
  1084.       INTEGER DONOD,E3NOD,VAR(7)
  1085.  
  1086.         COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  1087.         INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  1088.         SAVE
  1089.       INTEGER REFNOD,E1,E2,E3,VARNOD,VARNAM(7),TEXT(1322),
  1090.      +          CONONE(2), NE3NOD
  1091.  
  1092.       INTEGER NODETP,ZYNEXT,ZYDOWN,COMPAR,EQUAL
  1093.       EXTERNAL NODETP,ZYNEXT,ZYDOWN,COMPAR,GETSTR,EQUAL
  1094.  
  1095.       DATA CONONE/49,129/
  1096.  
  1097. C Check the type of DONOD.
  1098.       IF (NODETP(DONOD) .NE. 61) CALL ERROR('ISTCD: First'
  1099.      +      //' Argument Not Node of a DO Statement.')
  1100.  
  1101. C Get the DO variable and E3 node of the DO statement at DONOD
  1102.       REFNOD = ZYDOWN(DONOD)
  1103.       IF (NODETP(REFNOD) .EQ. 115) REFNOD = ZYNEXT(REFNOD)
  1104.       VARNOD = ZYDOWN(ZYNEXT(REFNOD))
  1105.       CALL GETSTR(VARNOD,VARNAM)
  1106.       E1 = ZYNEXT(VARNOD)
  1107.       E2 = ZYNEXT(E1)
  1108.       E3 = ZYNEXT(E2)
  1109.  
  1110. C Check for E3-equivalence.
  1111. C Compare DO variables.
  1112.       IF (EQUAL(VARNAM,VAR) .EQ. -3) THEN
  1113.          E3EQV = -3
  1114.          RETURN
  1115.       END IF
  1116. C Remove parentheses for comparing E3 nodes.
  1117.    10 CONTINUE
  1118.       IF(E3 .GT. 0) THEN
  1119.         IF (NODETP(E3) .EQ. 101) THEN
  1120.           E3 = ZYDOWN(E3)
  1121.           GO TO 10
  1122.         END IF
  1123.       ENDIF
  1124.  
  1125.       NE3NOD = E3NOD
  1126.    20 CONTINUE
  1127.       IF(NE3NOD .GT. 0) THEN
  1128.         IF (NODETP(NE3NOD) .EQ. 101) THEN
  1129.           NE3NOD = ZYDOWN(NE3NOD)
  1130.           GO TO 20
  1131.         END IF
  1132.       ENDIF
  1133.  
  1134.       IF (E3 .EQ. 0 .AND. NE3NOD .EQ. 0) THEN
  1135. C Both E3s are default
  1136.          E3EQV = -2
  1137.       ELSE IF (E3 .EQ. 0 .AND. NE3NOD .NE. 0) THEN
  1138. C Check whether E3NOD (unparenthesized) is explicitly 1.
  1139.          IF (ZYDOWN(NE3NOD) .GE. 0) THEN
  1140. C E3NOD is not a leaf and hence not 1.
  1141.             E3EQV = -3
  1142.          ELSE
  1143.             CALL GETSTR(NE3NOD,TEXT)
  1144.             IF (EQUAL(TEXT,CONONE) .EQ. -2) THEN
  1145. C Unparenthesized E3NOD is explicitly 1.
  1146.                E3EQV = -2
  1147.             ELSE
  1148.                E3EQV = -3
  1149.             END IF
  1150.          END IF
  1151.         ELSE IF (E3 .NE. 0 .AND. NE3NOD .EQ. 0) THEN
  1152. C Check whether unparenthesized E3 is explicitly 1.
  1153.          IF (ZYDOWN(E3) .GE. 0) THEN
  1154. C E3 is not a leaf and hence not 1.
  1155.             E3EQV = -3
  1156.          ELSE
  1157.             CALL GETSTR(E3,TEXT)
  1158.             IF (EQUAL(TEXT,CONONE) .EQ. -2) THEN
  1159. C E3 is explicitly 1.
  1160.                E3EQV = -2
  1161.             ELSE
  1162.                E3EQV = -3
  1163.             END IF
  1164.          END IF
  1165.       ELSE IF (COMPAR(E3,NE3NOD) .EQ. -2) THEN
  1166. C E3s are not default and are identical.
  1167.          E3EQV = -2
  1168.       ELSE
  1169. C E3s are not default and are not identical.
  1170.          E3EQV = -3
  1171.       END IF
  1172.  
  1173.       END
  1174. C-----------------------   GENOUT.MAC
  1175. C ---------------------------------------------------------------------
  1176. C        G E N O U T - Output sequence with first two DOs condensed
  1177. C                      by general algorithm.  If either E1 or E2
  1178. C                   equivalence holds (not both) then only two of
  1179. C                   the four MIN/MAX statements and only one of the
  1180. C                   two IF-THEN-ELSE blocks need be written.
  1181. C
  1182.       SUBROUTINE GENOUT(VAR,E1,E2,E3,FIRST,LAST,NRDOS,NUMF,NUML)
  1183.  
  1184.       INTEGER VAR(7),E1(50),E2(50),E3,FIRST(50),LAST(50),NRDOS,
  1185.      +          NUMF,NUML
  1186.  
  1187.         COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  1188.         INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  1189.  
  1190.       INTEGER DUMMY(2),STRMIN(4),STRMAX(4),SNUM,
  1191.      +          E0(7),EE0(7),E(7),EE(7),JUNK(7),CONONE(2),
  1192.      +          TRMLBL(6),POINTR,COM0(43),COM1(45),COM2(45),
  1193.      +          COM3(40), I
  1194.       LOGICAL E1EQV,E2EQV
  1195.  
  1196.       INTEGER LENGTH,ZYNEXT,ZYPREV
  1197.       EXTERNAL GETIL,ZTOKWR,LENGTH,COMOUT,YSTMT,ZYNEXT,CHKEQV
  1198.  
  1199. C---------------------------------------------------------
  1200. C    TOOLPACK/1    Release: 2.1
  1201. C---------------------------------------------------------
  1202. C
  1203. C THIS IS USED BY BOTH ISTSB AND ISTCD
  1204. C
  1205. C This COMMON block contains the logical variable ITERAT which is
  1206. C set to .TRUE. when a condition is encountered that implies that
  1207. C further processing is required on the parse tree obtained from
  1208. C the token stream output from the current run.  ZQUIT is called
  1209. C with condition 'repeat' if and only if ITERAT is .TRUE.
  1210. C
  1211. C This COMMON block contains the logical variables ITERAT and CYCLE.
  1212.  
  1213.       COMMON /REPEAT/ ITERAT,CYCLE
  1214.       LOGICAL ITERAT,CYCLE
  1215.       SAVE
  1216. C---------------------------------------------------------
  1217. C    TOOLPACK/1    Release: 2.1
  1218. C---------------------------------------------------------
  1219. C
  1220. C  TKLAST = LAST TOKEN NUMBER
  1221. C
  1222.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  1223.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  1224.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  1225.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  1226.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  1227.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  1228.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  1229.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  1230.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  1231.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  1232.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  1233.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  1234.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  1235.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  1236.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  1237.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  1238.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  1239.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  1240.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  1241.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  1242.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  1243.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  1244.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  1245.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  1246.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  1247.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  1248.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  1249.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  1250.  
  1251.  
  1252. C "C*** DO loops condensed - general case ***"
  1253.       DATA COM0/67,42,42,42,32,68,79,32,108,
  1254.      +            111,111,112,115,32,99,111,110,100,101,
  1255.      +            110,115,101,100,32,45,32,103,101,110,
  1256.      +            101,114,97,108,32,99,97,115,101,32,
  1257.      +            42,42,42,129/
  1258.  
  1259.  
  1260. C "C*** DO loops condensed - E1 equivalence ***"
  1261.       DATA COM1/67,42,42,42,32,68,79,32,108,
  1262.      +            111,111,112,115,32,99,111,110,100,101,
  1263.      +            110,115,101,100,32,45,32,69,49,32,
  1264.      +            101,113,117,105,118,97,108,101,110,99,
  1265.      +            101,32,42,42,42,129/
  1266.  
  1267. C "C*** DO loops condensed - E2 equivalence ***"
  1268.       DATA COM2/67,42,42,42,32,68,79,32,108,
  1269.      +            111,111,112,115,32,99,111,110,100,101,
  1270.      +            110,115,101,100,32,45,32,69,50,32,
  1271.      +            101,113,117,105,118,97,108,101,110,99,
  1272.      +            101,32,42,42,42,129/
  1273.  
  1274. C "C*** WARNING: Possible Dependencies ***"
  1275.       DATA COM3/67,42,42,42,32,87,65,82,78,
  1276.      +            73,78,71,58,32,80,111,115,115,
  1277.      +            105,98,108,101,32,68,101,112,101,
  1278.      +            110,100,101,110,99,105,101,115,32,42,
  1279.      +            42,42,129/
  1280.  
  1281.       DATA DUMMY(1)/129/
  1282.       DATA CONONE/49,129/
  1283.       DATA STRMIN/77,73,78,129/
  1284.       DATA STRMAX/77,65,88,129/
  1285.  
  1286.       SNUM = NUMF
  1287.  
  1288. C Check for E1 or E2 equivalence of the first two DOs.
  1289.       CALL CHKEQV(E1,E2,2,E1EQV,E2EQV)
  1290.  
  1291.       IF (E1EQV) THEN
  1292. C Write a comment that loops being consensed - E1 equivalence
  1293.           CALL ZTOKWR(TCMMNT,LENGTH(COM1),COM1,TKNCHN)
  1294.           CALL ZTOKWR(TCMMNT,LENGTH(COM3),COM3,TKNCHN)
  1295.       ELSE IF (E2EQV) THEN
  1296. C Write a comment that loops being consensed - E2 equivalence
  1297.           CALL ZTOKWR(TCMMNT,LENGTH(COM2),COM2,TKNCHN)
  1298.           CALL ZTOKWR(TCMMNT,LENGTH(COM3),COM3,TKNCHN)
  1299.       ELSE
  1300. C Write a comment that loops being consensed - general case
  1301.           CALL ZTOKWR(TCMMNT,LENGTH(COM0),COM0,TKNCHN)
  1302.           CALL ZTOKWR(TCMMNT,LENGTH(COM3),COM3,TKNCHN)
  1303.       END IF
  1304.  
  1305. C Fix comment stream file descriptor
  1306.  
  1307. C Generate names for the MIN/MAX parameters.
  1308.       CALL GETIL(E0,JUNK)
  1309.       CALL GETIL(EE0,JUNK)
  1310.       CALL GETIL(E,JUNK)
  1311.       CALL GETIL(EE,JUNK)
  1312.  
  1313. C Write the MIN/MAX statements.
  1314.  
  1315. C First MIN
  1316.       IF (E1EQV) GO TO 1000
  1317. C e0
  1318.       CALL ZTOKWR(TNAME,LENGTH(E0),E0,TKNCHN)
  1319. C =
  1320.         CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
  1321. C MIN
  1322.       CALL ZTOKWR(TNAME,LENGTH(STRMIN),STRMIN,TKNCHN)
  1323. C (
  1324.         CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1325. C (e1)
  1326.         CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1327.       CALL YEXPR(E1(1),TKNCHN)
  1328.         CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1329. C *
  1330.         CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
  1331. C 1 or (e3)
  1332.       IF (E3 .EQ. 0) THEN
  1333.          CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  1334.       ELSE
  1335.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1336.          CALL YEXPR(E3,TKNCHN)
  1337.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1338.       END IF
  1339. C ,
  1340.         CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  1341. C (E1)
  1342.         CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1343.       CALL YEXPR(E1(2),TKNCHN)
  1344.         CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1345. C *
  1346.         CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
  1347. C 1 or (e3)
  1348.       IF (E3 .EQ. 0) THEN
  1349.          CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  1350.       ELSE
  1351.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1352.          CALL YEXPR(E3,TKNCHN)
  1353.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1354.       END IF
  1355. C )
  1356.         CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1357. C /
  1358.         CALL ZTOKWR(TSLASH,0,DUMMY(1),TKNCHN)
  1359. C 1 or (e3)
  1360.       IF (E3 .EQ. 0) THEN
  1361.          CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  1362.       ELSE
  1363.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1364.          CALL YEXPR(E3,TKNCHN)
  1365.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1366.       END IF
  1367. C end-of-statement (first MIN)
  1368.         CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  1369. 1000      CONTINUE
  1370.  
  1371. C First MAX
  1372.       IF (E2EQV) GO TO 2000
  1373. C E0
  1374.       CALL ZTOKWR(TNAME,LENGTH(EE0),EE0,TKNCHN)
  1375. C =
  1376.         CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
  1377. C MAX
  1378.       CALL ZTOKWR(TNAME,LENGTH(STRMAX),STRMAX,TKNCHN)
  1379. C (
  1380.         CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1381. C (e2)
  1382.         CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1383.       CALL YEXPR(E2(1),TKNCHN)
  1384.         CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1385. C *
  1386.         CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
  1387. C 1 or (e3)
  1388.       IF (E3 .EQ. 0) THEN
  1389.          CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  1390.       ELSE
  1391.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1392.          CALL YEXPR(E3,TKNCHN)
  1393.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1394.       END IF
  1395. C ,
  1396.         CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  1397. C (E2)
  1398.         CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1399.       CALL YEXPR(E2(2),TKNCHN)
  1400.         CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1401. C *
  1402.         CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
  1403. C 1 or (e3)
  1404.       IF (E3 .EQ. 0) THEN
  1405.          CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  1406.       ELSE
  1407.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1408.          CALL YEXPR(E3,TKNCHN)
  1409.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1410.       END IF
  1411. C )
  1412.         CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1413. C /
  1414.         CALL ZTOKWR(TSLASH,0,DUMMY(1),TKNCHN)
  1415. C 1 or (e3)
  1416.       IF (E3 .EQ. 0) THEN
  1417.          CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  1418.       ELSE
  1419.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1420.          CALL YEXPR(E3,TKNCHN)
  1421.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1422.       END IF
  1423. C end-of-statement (first MAX)
  1424.         CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  1425. 2000      CONTINUE
  1426.  
  1427. C Second MAX
  1428.       IF (E1EQV) GO TO 3000
  1429. C e
  1430.       CALL ZTOKWR(TNAME,LENGTH(E),E,TKNCHN)
  1431. C =
  1432.         CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
  1433. C MAX
  1434.       CALL ZTOKWR(TNAME,LENGTH(STRMAX),STRMAX,TKNCHN)
  1435. C (
  1436.         CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1437. C (e1)
  1438.         CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1439.       CALL YEXPR(E1(1),TKNCHN)
  1440.         CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1441. C *
  1442.         CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
  1443. C 1 or (e3)
  1444.       IF (E3 .EQ. 0) THEN
  1445.          CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  1446.       ELSE
  1447.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1448.          CALL YEXPR(E3,TKNCHN)
  1449.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1450.       END IF
  1451. C ,
  1452.         CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  1453. C (E1)
  1454.         CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1455.       CALL YEXPR(E1(2),TKNCHN)
  1456.         CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1457. C *
  1458.         CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
  1459. C 1 or (e3)
  1460.       IF (E3 .EQ. 0) THEN
  1461.          CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  1462.       ELSE
  1463.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1464.          CALL YEXPR(E3,TKNCHN)
  1465.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1466.       END IF
  1467. C )
  1468.         CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1469. C /
  1470.         CALL ZTOKWR(TSLASH,0,DUMMY(1),TKNCHN)
  1471. C 1 or (e3)
  1472.       IF (E3 .EQ. 0) THEN
  1473.          CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  1474.       ELSE
  1475.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1476.          CALL YEXPR(E3,TKNCHN)
  1477.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1478.       END IF
  1479. C end-of-statement (Second MAX)
  1480.         CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  1481. 3000      CONTINUE
  1482.  
  1483. C Second MIN
  1484.       IF (E2EQV) GO TO 4000
  1485. C E
  1486.       CALL ZTOKWR(TNAME,LENGTH(EE),EE,TKNCHN)
  1487. C =
  1488.         CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
  1489. C MIN
  1490.       CALL ZTOKWR(TNAME,LENGTH(STRMIN),STRMIN,TKNCHN)
  1491. C (
  1492.         CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1493. C (e2)
  1494.         CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1495.       CALL YEXPR(E2(1),TKNCHN)
  1496.         CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1497. C *
  1498.         CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
  1499. C 1 or (e3)
  1500.       IF (E3 .EQ. 0) THEN
  1501.          CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  1502.       ELSE
  1503.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1504.          CALL YEXPR(E3,TKNCHN)
  1505.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1506.       END IF
  1507. C ,
  1508.         CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  1509. C (E2)
  1510.         CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1511.       CALL YEXPR(E2(2),TKNCHN)
  1512.         CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1513. C *
  1514.         CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
  1515. C 1 or (e3)
  1516.       IF (E3 .EQ. 0) THEN
  1517.          CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  1518.       ELSE
  1519.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1520.          CALL YEXPR(E3,TKNCHN)
  1521.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1522.       END IF
  1523. C )
  1524.         CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1525. C /
  1526.         CALL ZTOKWR(TSLASH,0,DUMMY(1),TKNCHN)
  1527. C 1 or (e3)
  1528.       IF (E3 .EQ. 0) THEN
  1529.          CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  1530.       ELSE
  1531.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1532.          CALL YEXPR(E3,TKNCHN)
  1533.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1534.       END IF
  1535. C end-of-statement (second MIN)
  1536.         CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  1537. 4000      CONTINUE
  1538.  
  1539. C Write the first IF-THEN-ELSE
  1540.       IF (E1EQV) GO TO 5000
  1541. C IF
  1542.         CALL ZTOKWR(TIF,0,DUMMY(1),TKNCHN)
  1543. C (
  1544.         CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1545. C (e1)
  1546.         CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1547.       CALL YEXPR(E1(1),TKNCHN)
  1548.         CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1549. C .EQ.
  1550.         CALL ZTOKWR(TEQ,0,DUMMY(1),TKNCHN)
  1551. C e0
  1552.       CALL ZTOKWR(TNAME,LENGTH(E0),E0,TKNCHN)
  1553. C )
  1554.         CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1555. C THEN
  1556.         CALL ZTOKWR(TTHEN,0,DUMMY(1),TKNCHN)
  1557. C end-of-statement (first IF-THEN)
  1558.         CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  1559.  
  1560. C Write first clean-up DO
  1561.       CALL GETIL(JUNK,TRMLBL)
  1562. C DO
  1563.         CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
  1564. C termination label reference
  1565.         CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
  1566. C DO variable
  1567.         CALL ZTOKWR(TNAME,LENGTH(VAR),VAR,TKNCHN)
  1568. C =
  1569.         CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
  1570. C e0
  1571.       CALL ZTOKWR(TNAME,LENGTH(E0),E0,TKNCHN)
  1572. C ,
  1573.         CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  1574. C e
  1575.       CALL ZTOKWR(TNAME,LENGTH(E),E,TKNCHN)
  1576. C -
  1577.         CALL ZTOKWR(TMINUS,0,DUMMY(1),TKNCHN)
  1578. C 1 or (e3)
  1579.       IF (E3 .EQ. 0) THEN
  1580.          CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  1581.       ELSE
  1582.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1583.          CALL YEXPR(E3,TKNCHN)
  1584.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1585.       END IF
  1586. C ,
  1587.         CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  1588. C 1 or (e3)
  1589.       IF (E3 .EQ. 0) THEN
  1590.          CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  1591.       ELSE
  1592.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1593.          CALL YEXPR(E3,TKNCHN)
  1594.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1595.       END IF
  1596. C end-of-statement (first clean-up DO)
  1597.         CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  1598.  
  1599. C Write the range of the first DO.
  1600.       POINTR = FIRST(1)
  1601. 100      CONTINUE
  1602.       CALL YSTMT(POINTR,TKNCHN)
  1603.       IF (POINTR .NE. LAST(1)) THEN
  1604.          POINTR = ZYNEXT(POINTR)
  1605.          GO TO 100
  1606.       END IF
  1607.  
  1608. C Write the terminating CONTINUE.
  1609. C Terminating label
  1610.       CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
  1611. C CONTINUE
  1612.       CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
  1613. C end-of-statement (CONTINUE statement)
  1614.       CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  1615.  
  1616. C ELSE
  1617.       CALL ZTOKWR(TELSE,0,DUMMY(1),TKNCHN)
  1618. C end-of-statement (ELSE statement)
  1619.       CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  1620.  
  1621. C Write second clean-up DO
  1622.       CALL GETIL(JUNK,TRMLBL)
  1623. C DO
  1624.         CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
  1625. C termination label reference
  1626.         CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
  1627. C DO variable
  1628.         CALL ZTOKWR(TNAME,LENGTH(VAR),VAR,TKNCHN)
  1629. C =
  1630.         CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
  1631. C e0
  1632.       CALL ZTOKWR(TNAME,LENGTH(E0),E0,TKNCHN)
  1633. C ,
  1634.         CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  1635. C e
  1636.       CALL ZTOKWR(TNAME,LENGTH(E),E,TKNCHN)
  1637. C -
  1638.         CALL ZTOKWR(TMINUS,0,DUMMY(1),TKNCHN)
  1639. C 1 or (e3)
  1640.       IF (E3 .EQ. 0) THEN
  1641.          CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  1642.       ELSE
  1643.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1644.          CALL YEXPR(E3,TKNCHN)
  1645.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1646.       END IF
  1647. C ,
  1648.         CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  1649. C 1 or (e3)
  1650.       IF (E3 .EQ. 0) THEN
  1651.          CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  1652.       ELSE
  1653.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1654.          CALL YEXPR(E3,TKNCHN)
  1655.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1656.       END IF
  1657. C end-of-statement (second clean-up DO)
  1658.         CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  1659.  
  1660. C Write the range of the second DO.
  1661.       POINTR = FIRST(2)
  1662. 200      CONTINUE
  1663.       CALL YSTMT(POINTR,TKNCHN)
  1664.       IF (POINTR .NE. LAST(2)) THEN
  1665.          POINTR = ZYNEXT(POINTR)
  1666.          GO TO 200
  1667.       END IF
  1668.  
  1669. C Write the terminating CONTINUE.
  1670. C Terminating label
  1671.       CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
  1672. C CONTINUE
  1673.       CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
  1674. C end-of-statement (CONTINUE statement)
  1675.       CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  1676.  
  1677. C END IF
  1678.       CALL ZTOKWR(TENDIF,0,DUMMY(1),TKNCHN)
  1679. C end-of-statement (END IF statement)
  1680.       CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  1681. 5000      CONTINUE
  1682.  
  1683. C Write the second IF-THEN-ELSE
  1684.       IF (E2EQV) GO TO 6000
  1685. C IF
  1686.         CALL ZTOKWR(TIF,0,DUMMY(1),TKNCHN)
  1687. C (
  1688.         CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1689. C (e2)
  1690.         CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1691.       CALL YEXPR(E2(1),TKNCHN)
  1692.         CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1693. C .EQ.
  1694.         CALL ZTOKWR(TEQ,0,DUMMY(1),TKNCHN)
  1695. C E0
  1696.       CALL ZTOKWR(TNAME,LENGTH(EE0),EE0,TKNCHN)
  1697. C )
  1698.         CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1699. C THEN
  1700.         CALL ZTOKWR(TTHEN,0,DUMMY(1),TKNCHN)
  1701. C end-of-statement (second IF-THEN)
  1702.         CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  1703.  
  1704. C Write third clean-up DO
  1705.       CALL GETIL(JUNK,TRMLBL)
  1706. C DO
  1707.         CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
  1708. C termination label reference
  1709.         CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
  1710. C DO variable
  1711.         CALL ZTOKWR(TNAME,LENGTH(VAR),VAR,TKNCHN)
  1712. C =
  1713.         CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
  1714. C E
  1715.       CALL ZTOKWR(TNAME,LENGTH(EE),EE,TKNCHN)
  1716. C +
  1717.         CALL ZTOKWR(TPLUS,0,DUMMY(1),TKNCHN)
  1718. C 1 or (e3)
  1719.       IF (E3 .EQ. 0) THEN
  1720.          CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  1721.       ELSE
  1722.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1723.          CALL YEXPR(E3,TKNCHN)
  1724.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1725.       END IF
  1726. C ,
  1727.         CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  1728. C E0
  1729.       CALL ZTOKWR(TNAME,LENGTH(EE0),EE0,TKNCHN)
  1730. C ,
  1731.         CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  1732. C 1 or (e3)
  1733.       IF (E3 .EQ. 0) THEN
  1734.          CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  1735.       ELSE
  1736.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1737.          CALL YEXPR(E3,TKNCHN)
  1738.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1739.       END IF
  1740. C end-of-statement (third clean-up DO)
  1741.         CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  1742.  
  1743. C Write the range of the first DO.
  1744.       POINTR = FIRST(1)
  1745. 300      CONTINUE
  1746.       CALL YSTMT(POINTR,TKNCHN)
  1747.       IF (POINTR .NE. LAST(1)) THEN
  1748.          POINTR = ZYNEXT(POINTR)
  1749.          GO TO 300
  1750.       END IF
  1751.  
  1752. C Write the terminating CONTINUE.
  1753. C Terminating label
  1754.       CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
  1755. C CONTINUE
  1756.       CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
  1757. C end-of-statement (CONTINUE statement)
  1758.       CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  1759.  
  1760. C ELSE
  1761.       CALL ZTOKWR(TELSE,0,DUMMY(1),TKNCHN)
  1762. C end-of-statement (ELSE statement)
  1763.       CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  1764.  
  1765. C Write fourth clean-up DO
  1766.       CALL GETIL(JUNK,TRMLBL)
  1767. C DO
  1768.         CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
  1769. C termination label reference
  1770.         CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
  1771. C DO variable
  1772.         CALL ZTOKWR(TNAME,LENGTH(VAR),VAR,TKNCHN)
  1773. C =
  1774.         CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
  1775. C E
  1776.       CALL ZTOKWR(TNAME,LENGTH(EE),EE,TKNCHN)
  1777. C +
  1778.         CALL ZTOKWR(TPLUS,0,DUMMY(1),TKNCHN)
  1779. C 1 or (e3)
  1780.       IF (E3 .EQ. 0) THEN
  1781.          CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  1782.       ELSE
  1783.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1784.          CALL YEXPR(E3,TKNCHN)
  1785.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1786.       END IF
  1787. C ,
  1788.         CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  1789. C E0
  1790.       CALL ZTOKWR(TNAME,LENGTH(EE0),EE0,TKNCHN)
  1791. C ,
  1792.         CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  1793. C 1 or (e3)
  1794.       IF (E3 .EQ. 0) THEN
  1795.          CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  1796.       ELSE
  1797.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1798.          CALL YEXPR(E3,TKNCHN)
  1799.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1800.       END IF
  1801. C end-of-statement (fourth clean-up DO)
  1802.         CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  1803.  
  1804. C Write the range of the second DO.
  1805.       POINTR = FIRST(2)
  1806. 400      CONTINUE
  1807.       CALL YSTMT(POINTR,TKNCHN)
  1808.       IF (POINTR .NE. LAST(2)) THEN
  1809.          POINTR = ZYNEXT(POINTR)
  1810.          GO TO 400
  1811.       END IF
  1812.  
  1813. C Write the terminating CONTINUE.
  1814. C Terminating label
  1815.       CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
  1816. C CONTINUE
  1817.       CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
  1818. C end-of-statement (CONTINUE statement)
  1819.       CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  1820.  
  1821. C END IF
  1822.       CALL ZTOKWR(TENDIF,0,DUMMY(1),TKNCHN)
  1823. C end-of-statement (END IF statement)
  1824.       CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  1825. 6000      CONTINUE
  1826.  
  1827. C Write the main DO
  1828.       CALL GETIL(JUNK,TRMLBL)
  1829. C DO
  1830.         CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
  1831. C termination label reference
  1832.         CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
  1833. C DO variable
  1834.         CALL ZTOKWR(TNAME,LENGTH(VAR),VAR,TKNCHN)
  1835. C =
  1836.         CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
  1837. C e (=e1 in case of E1 equivalence)
  1838.       IF (E1EQV) THEN
  1839.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1840.          CALL YEXPR(E1(1),TKNCHN)
  1841.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1842.       ELSE
  1843.          CALL ZTOKWR(TNAME,LENGTH(E),E,TKNCHN)
  1844.       END IF
  1845. C ,
  1846.         CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  1847. C E (=E2 in case of E2 equivalence)
  1848.       IF (E2EQV) THEN
  1849.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1850.          CALL YEXPR(E2(2),TKNCHN)
  1851.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1852.       ELSE
  1853.          CALL ZTOKWR(TNAME,LENGTH(EE),EE,TKNCHN)
  1854.       END IF
  1855. C ,
  1856.         CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  1857. C 1 or (e3)
  1858.       IF (E3 .EQ. 0) THEN
  1859.          CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  1860.       ELSE
  1861.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  1862.          CALL YEXPR(E3,TKNCHN)
  1863.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  1864.       END IF
  1865. C end-of-statement (main DO)
  1866.         CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  1867.  
  1868. C Write the concatenation of the ranges of the DOs.
  1869.       DO 500 I = 1,2
  1870.          SNUM = SNUM + I
  1871.          POINTR = FIRST(I)
  1872. 600         CONTINUE
  1873.          CALL YSTMT(POINTR,TKNCHN)
  1874.          SNUM = SNUM + 1
  1875.          CALL COMOUT(SNUM)
  1876.          IF (POINTR .NE. LAST(I)) THEN
  1877.             POINTR = ZYNEXT(POINTR)
  1878.             GO TO 600
  1879.          END IF
  1880. 500      CONTINUE
  1881.  
  1882. C Write the terminating CONTINUE.
  1883. C Terminating label
  1884.       CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
  1885. C CONTINUE
  1886.       CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
  1887. C end-of-statement (CONTINUE statement)
  1888.       CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  1889.       SNUM = SNUM + 1
  1890.       CALL COMOUT(SNUM)
  1891.  
  1892. C Ouput the remaining DOs in the sequence
  1893.       DO 700 I = 3,NRDOS
  1894.          POINTR = FIRST(I)
  1895.          CALL YSTMT(ZYPREV(POINTR),TKNCHN)
  1896.          SNUM = SNUM + 1
  1897.          CALL COMOUT(SNUM)
  1898. 800         CONTINUE
  1899.          CALL YSTMT(POINTR,TKNCHN)
  1900.          SNUM = SNUM + 1
  1901.          CALL COMOUT(SNUM)
  1902.          IF (POINTR .NE. LAST(I)) THEN
  1903.             POINTR = ZYNEXT(POINTR)
  1904.             GO TO 800
  1905.          END IF
  1906.          CALL YSTMT(ZYNEXT(POINTR),TKNCHN)
  1907.          SNUM = SNUM + 1
  1908.          CALL COMOUT(SNUM)
  1909. 700      CONTINUE
  1910.  
  1911.       NUML = SNUM
  1912. C Set flag for iteration of ISTCD.
  1913.       ITERAT = .TRUE.
  1914.  
  1915.       RETURN
  1916.       END
  1917. C-----------------------   GETIL.MAC
  1918.       SUBROUTINE GETIL(DOVAR, LABEL)
  1919. C Generate a variable and a label for use by ISTCD.  Each call
  1920. C results in DOVAR being set (as an IST string) to the next member of the
  1921. C sequence Mxxxxx, Myyyyy, (where yyyyy is xxxxx decremented by 1) ...
  1922. C and LABEL being set (as an IST string) to the corresponding string
  1923. C without the leading 'M'.  The first value of xxxxx is CURLBL in COMMON
  1924. C block CLAB.
  1925.  
  1926.       INTEGER DOVAR(7),LABEL(6),RESULT(8), ZYFSYM
  1927.  
  1928.       COMMON /CLAB/ CURLBL,CURPUN,FIRST
  1929.       LOGICAL FIRST
  1930.       INTEGER CURLBL,CURPUN
  1931.  
  1932.       EXTERNAL ZITOCP
  1933.  
  1934.       SAVE
  1935.  
  1936.    10 CONTINUE
  1937.       CALL ZITOCP(CURLBL,LABEL,5,48)
  1938.       DOVAR(1) = 77
  1939.       CALL SCOPY(LABEL,1,DOVAR,2)
  1940.       DOVAR(7) = 129
  1941.  
  1942.       IF(ZYFSYM(DOVAR, CURPUN, RESULT) .NE. -1 .OR.
  1943.      +   ZYFSYM(LABEL, CURPUN, RESULT) .NE. -1) THEN
  1944.         CURLBL = CURLBL - 1
  1945.         GO TO 10
  1946.       ENDIF
  1947.  
  1948.       CURLBL = CURLBL - 1
  1949.  
  1950.       END
  1951. C-----------------------   ICOD1.MAC
  1952. C ---------------------------------------------------------------------
  1953. C          I C O D 1 - Test whether a DO and its immediately following
  1954. C                     statement match either the f01ae or f01af paradigm;
  1955. C                      if so, output the transformed (peeled) code.
  1956. C
  1957.        SUBROUTINE ICOD1(VARNOD,E1,E2,E3,FIRST,LAST,NUMF,NUML,SIC)
  1958.  
  1959.        INTEGER VARNOD,E1,E2,E3,FIRST,LAST,NUMF,NUML
  1960.        LOGICAL SIC
  1961.  
  1962.         INTEGER I
  1963.  
  1964.       COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  1965.       INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  1966. C---------------------------------------------------------
  1967. C    TOOLPACK/1    Release: 2.1
  1968. C---------------------------------------------------------
  1969. C
  1970. C THIS IS USED BY BOTH ISTSB AND ISTCD
  1971. C
  1972. C This COMMON block contains the logical variable ITERAT which is
  1973. C set to .TRUE. when a condition is encountered that implies that
  1974. C further processing is required on the parse tree obtained from
  1975. C the token stream output from the current run.  ZQUIT is called
  1976. C with condition 'repeat' if and only if ITERAT is .TRUE.
  1977. C
  1978. C This COMMON block contains the logical variables ITERAT and CYCLE.
  1979.  
  1980.       COMMON /REPEAT/ ITERAT,CYCLE
  1981.       LOGICAL ITERAT,CYCLE
  1982.  
  1983.        INTEGER FOLSTM,JSTR(1322),CSTR(1322),SPTR,SNUM,
  1984.      +          COM(25),DOVAR(7),TRMLBL(6),DUMMY(2),CONONE(2),
  1985.      +          JUNK(7),CP1STR(4),NUM1,NUM4,VALC,NRDIG,PONE(1322),
  1986.      +          DNODES(200),NRDEPS,LHSFOL,LHSNOD
  1987.        LOGICAL CASE1,CASE2,JM0
  1988.  
  1989.        INTEGER LENGTH,ZYNEXT,NODETP,INDJP1,CTOI,ITOC,
  1990.      +          EQUAL,JPMC1,INDJM1,COMPAR,ZYDOWN
  1991.        EXTERNAL GETIL,YEXPR,COMOUT,LENGTH,ZTOKWR,YSTMT,
  1992.      +           ZYNEXT,CHKEQV,NODETP,GETSTR,INDJP1,
  1993.      +           CTOI,ITOC,EQUAL,JPMC1,INDJM1,COMPAR,ZYDOWN
  1994.  
  1995. C---------------------------------------------------------
  1996. C    TOOLPACK/1    Release: 2.1
  1997. C---------------------------------------------------------
  1998. C
  1999. C  TKLAST = LAST TOKEN NUMBER
  2000. C
  2001.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  2002.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  2003.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  2004.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  2005.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  2006.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  2007.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  2008.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  2009.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  2010.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  2011.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  2012.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  2013.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  2014.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  2015.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  2016.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  2017.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  2018.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  2019.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  2020.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  2021.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  2022.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  2023.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  2024.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  2025.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  2026.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  2027.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  2028.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  2029.  
  2030.        SAVE
  2031.  
  2032.        DATA DUMMY(1)/129/
  2033.        DATA CONONE/49,129/
  2034.  
  2035.        DATA COM/67,42,42,42,32,80,101,101,108,
  2036.      +           105,110,103,32,97,112,112,108,105,
  2037.      +           101,100,32,42,42,42,129/
  2038.  
  2039. C E3 must be 0 in both cases.
  2040.        IF (E3 .NE. 0) THEN
  2041.           SIC = .FALSE.
  2042.           RETURN
  2043.        END IF
  2044. C The two cases are "true until proven false".  (At least one will
  2045. C be false.)
  2046.        CASE1 = .TRUE.
  2047.        CASE2 = .TRUE.
  2048. C Does xpr(E1) have form (J + c) + 1?
  2049.        IF (JPMC1(E1,JSTR,1,CSTR,1) .EQ. -3) CASE1 = .FALSE.
  2050.  
  2051. C If case 1 is false then is xpr(E1) = 1 and does xpr(E2) have form
  2052. C (J - c) -1?
  2053.  
  2054.        IF (.NOT. CASE1) THEN
  2055.           IF (ZYDOWN(E1) .GE. 0) THEN
  2056.              CASE2 = .FALSE.
  2057.           ELSE
  2058.              CALL GETSTR(E1,PONE)
  2059.              IF (EQUAL(PONE,CONONE) .NE. -2) CASE2 = .FALSE.
  2060.           END IF
  2061.           IF (CASE2) THEN
  2062.              IF (JPMC1(E2,JSTR,0,CSTR,0) .EQ. -3) CASE2 = .FALSE.
  2063.           END IF
  2064.        END IF
  2065.  
  2066.        IF ((.NOT. CASE1) .AND. (.NOT. CASE2)) THEN
  2067.           SIC = .FALSE.
  2068.           RETURN
  2069.        END IF
  2070.  
  2071. C The DO parameters satisfy one of the cases.
  2072. C Calculate c + 1 and convert it to the string CP1STR.
  2073.        NUM1 = 1
  2074.        NUM4 = 4
  2075.        VALC = CTOI(CSTR,NUM1)
  2076.        VALC = VALC + 1
  2077.        NRDIG = ITOC(VALC,CP1STR,NUM4)
  2078.  
  2079. C Is the statement immediately following the loop an assignment in which
  2080. C the lhs is an array element?
  2081.        FOLSTM = ZYNEXT(ZYNEXT(LAST))
  2082.        IF (NODETP(FOLSTM) .NE. 49) THEN
  2083.           SIC = .FALSE.
  2084.           RETURN
  2085.        END IF
  2086.  
  2087.        LHSFOL = ZYDOWN(FOLSTM)
  2088.        IF (NODETP(LHSFOL) .EQ. 115) LHSFOL = ZYNEXT(LHSFOL)
  2089.        IF (NODETP(LHSFOL) .NE. 104) THEN
  2090.           SIC = .FALSE.
  2091.           RETURN
  2092.        END IF
  2093.  
  2094.        IF (CASE1) THEN
  2095. C Does every array index in the statement following the loop have form
  2096. C JSTR + k for k = c+1,...0.
  2097.           IF (INDJP1(FOLSTM,JSTR,CP1STR) .EQ. -3) CASE1 = .FALSE.
  2098.        END IF
  2099.  
  2100.        IF (.NOT. CASE1) THEN
  2101. C Does every array index in the statement following the loop have form
  2102. C JSTR - k for k = c+1,...1.
  2103.           IF (INDJM1(FOLSTM,JSTR,CP1STR,JM0) .EQ. -3) CASE2 = .FALSE.
  2104. C We require that k > 0 for every index.
  2105.           IF (JM0) CASE2 = .FALSE.
  2106.        END IF
  2107.  
  2108.        IF ((.NOT. CASE1) .AND. (.NOT. CASE2)) THEN
  2109.           SIC = .FALSE.
  2110.           RETURN
  2111.        END IF
  2112.  
  2113. C The parameters for one of the cases are satisfied.  Is every
  2114. C statement in the range of the DO an assignment for which the
  2115. C lhs is an array element whose indices are the DO variable?
  2116.  
  2117.        SPTR = FIRST
  2118. 40       CONTINUE
  2119. C Assignment?
  2120.        IF (NODETP(SPTR) .NE. 49) THEN
  2121.           SIC = .FALSE.
  2122.           RETURN
  2123.        END IF
  2124.  
  2125. C Array Element?
  2126.        LHSNOD = ZYDOWN(SPTR)
  2127.        IF (NODETP(LHSNOD) .EQ. 115) LHSNOD = ZYNEXT(LHSNOD)
  2128.        IF (NODETP(LHSNOD) .NE. 104) THEN
  2129.           SIC = .FALSE.
  2130.           RETURN
  2131.        END IF
  2132.  
  2133. C Indices are DO variable (remove parentheses before checking)?
  2134.        LHSNOD = ZYNEXT(ZYDOWN(LHSNOD))
  2135. 60       CONTINUE
  2136.        IF (NODETP(LHSNOD) .EQ. 101) THEN
  2137.           LHSNOD = ZYDOWN(LHSNOD)
  2138.           GO TO 60
  2139.        END IF
  2140.        IF (COMPAR(LHSNOD,VARNOD) .NE. -2) THEN
  2141.           SIC = .FALSE.
  2142.           RETURN
  2143.        END IF
  2144.        LHSNOD = ZYNEXT(LHSNOD)
  2145.        IF (LHSNOD .NE. 0) GO TO 60
  2146.  
  2147.        IF (SPTR .NE. LAST) THEN
  2148.           SPTR = ZYNEXT(SPTR)
  2149.           GO TO 40
  2150.        END IF
  2151.  
  2152. C Is FOLSTM an assignment to a member of the dependency set of
  2153. C a statement in the DO range?
  2154.        SPTR = FIRST
  2155. 50       CONTINUE
  2156.        CALL DEPSET(SPTR,DNODES,NRDEPS)
  2157.        DO 500 I=1,NRDEPS
  2158.           IF (COMPAR(LHSFOL,DNODES(I)) .EQ. -2) THEN
  2159.              SIC = .FALSE.
  2160.              RETURN
  2161.           END IF
  2162. 500       CONTINUE
  2163.        IF (SPTR .NE. LAST) THEN
  2164.           SPTR = ZYNEXT(SPTR)
  2165.           GO TO 50
  2166.        END IF
  2167.  
  2168. C The conditions for one of the intervening code special cases
  2169. C (f01ae, f01af paradigms) are satisfied.  Output the transformed code.
  2170. C First output comment that peeling being applied.
  2171.        CALL ZTOKWR(TCMMNT,LENGTH(COM),COM,TKNCHN)
  2172.        IF (CASE1) THEN
  2173.           CALL ZMESS('Paradigm PAE.',2)
  2174.        ELSE IF (CASE2) THEN
  2175.           CALL ZMESS('Paradigm PAF.',2)
  2176.        END IF
  2177.        SIC = .TRUE.
  2178.        SNUM = NUMF
  2179.  
  2180. C Output the range of the DO with one of the following substituted for
  2181. C the DO variable, DOVAR:
  2182. C     xpr(JSTR) + xpr(CP1STR) if case 1 is true
  2183. C     xpr(JSTR) - xpr(CP1STR) if case 2 is true
  2184.  
  2185.  
  2186.        CALL GETSTR(VARNOD,DOVAR)
  2187.        SPTR = FIRST
  2188.  
  2189.        IF (CASE1) THEN
  2190. 10          CONTINUE
  2191.            CALL UASGN(SPTR,DOVAR,JSTR,CP1STR,0,TKNCHN)
  2192.           IF (SPTR .NE. LAST) THEN
  2193.              SPTR = ZYNEXT(SPTR)
  2194.              GO TO 10
  2195.           END IF
  2196.        ELSE IF (CASE2) THEN
  2197. 30          CONTINUE
  2198.            CALL UASGN(SPTR,DOVAR,JSTR,CP1STR,-1,TKNCHN)
  2199.           IF (SPTR .NE. LAST) THEN
  2200.              SPTR = ZYNEXT(SPTR)
  2201.              GO TO 30
  2202.           END IF
  2203.        END IF
  2204.  
  2205. C Output the intervening code, namely the statement following the DO.
  2206.        CALL YSTMT(FOLSTM,TKNCHN)
  2207.  
  2208. C Output the DO with the parameters set as follows:
  2209. C     E1 set to (JSTR + CP1STR) + 1 if case 1 is true
  2210. C     E2 set to (JSTR - CP1STR) - 1 if case 2 is true
  2211.  
  2212. C Generate the termination label.
  2213.        CALL GETIL(JUNK,TRMLBL)
  2214. C DO
  2215.         CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
  2216. C termination label reference
  2217.         CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
  2218. C DO variable
  2219.         CALL ZTOKWR(TNAME,LENGTH(DOVAR),DOVAR,TKNCHN)
  2220. C =
  2221.         CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
  2222.        IF (CASE1) THEN
  2223. C (
  2224.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  2225. C JSTR
  2226.            CALL ZTOKWR(TNAME,LENGTH(JSTR),JSTR,TKNCHN)
  2227. C +
  2228.            CALL ZTOKWR(TPLUS,0,DUMMY(1),TKNCHN)
  2229. C CP1STR
  2230.            CALL ZTOKWR(TDCNST,LENGTH(CP1STR),CP1STR,TKNCHN)
  2231. C )
  2232.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  2233. C +
  2234.            CALL ZTOKWR(TPLUS,0,DUMMY(1),TKNCHN)
  2235. C 1
  2236.            CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  2237.        ELSE IF (CASE2) THEN
  2238. C 1
  2239.            CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  2240.        END IF
  2241. C ,
  2242.            CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  2243.        IF (CASE1) THEN
  2244. C E2
  2245.           CALL YEXPR(E2,TKNCHN)
  2246.        ELSE IF (CASE2) THEN
  2247. C (
  2248.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  2249. C JSTR
  2250.            CALL ZTOKWR(TNAME,LENGTH(JSTR),JSTR,TKNCHN)
  2251. C -
  2252.            CALL ZTOKWR(TMINUS,0,DUMMY(1),TKNCHN)
  2253. C CP1STR
  2254.            CALL ZTOKWR(TDCNST,LENGTH(CP1STR),CP1STR,TKNCHN)
  2255. C )
  2256.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  2257. C -
  2258.            CALL ZTOKWR(TMINUS,0,DUMMY(1),TKNCHN)
  2259. C 1
  2260.            CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  2261.        END IF
  2262. C end-of-statement (modified DO)
  2263.            CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  2264.           SNUM = SNUM + 1
  2265.           CALL COMOUT(SNUM)
  2266. C Write the range
  2267.           SPTR = FIRST
  2268. 20          CONTINUE
  2269.           CALL YSTMT(SPTR,TKNCHN)
  2270.           SNUM = SNUM + 1
  2271.           CALL COMOUT(SNUM)
  2272.           IF (SPTR .NE. LAST) THEN
  2273.              SPTR = ZYNEXT(SPTR)
  2274.              GO TO 20
  2275.           END IF
  2276. C Write the terminating CONTINUE.
  2277. C Terminating label
  2278.           CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
  2279. C CONTINUE
  2280.           CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
  2281. C end-of-statement (CONTINUE statement)
  2282.           CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  2283.           SNUM = SNUM + 1
  2284.           CALL COMOUT(SNUM)
  2285.           NUML = SNUM
  2286. C Set flag for cycling ISTSB/ISTCD.
  2287.           CYCLE = .TRUE.
  2288.  
  2289.        END
  2290. C-----------------------   ICOD2.MAC
  2291. C ---------------------------------------------------------------------
  2292. C          I C O D 2 - Test whether a DO and its immediately preceding
  2293. C                     statements satisfy the f01ad paradigm; if so,
  2294. C                      output the transformed (peeled) code.
  2295. C
  2296.        SUBROUTINE ICOD2(VARNOD,E1,E2,E3,FIRST,LAST,NUMF,NUML,
  2297.      +                   BEGBLK,NRBLK,SIC)
  2298.  
  2299.        INTEGER VARNOD,E1,E2,E3,FIRST,LAST,NUMF,NUML,BEGBLK,NRBLK
  2300.        LOGICAL SIC
  2301.  
  2302.       COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  2303.       INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  2304.         SAVE
  2305.         INTEGER I, J, K
  2306.  
  2307. C---------------------------------------------------------
  2308. C    TOOLPACK/1    Release: 2.1
  2309. C---------------------------------------------------------
  2310. C
  2311. C THIS IS USED BY BOTH ISTSB AND ISTCD
  2312. C
  2313. C This COMMON block contains the logical variable ITERAT which is
  2314. C set to .TRUE. when a condition is encountered that implies that
  2315. C further processing is required on the parse tree obtained from
  2316. C the token stream output from the current run.  ZQUIT is called
  2317. C with condition 'repeat' if and only if ITERAT is .TRUE.
  2318. C
  2319. C This COMMON block contains the logical variables ITERAT and CYCLE.
  2320.  
  2321.       COMMON /REPEAT/ ITERAT,CYCLE
  2322.       LOGICAL ITERAT,CYCLE
  2323.  
  2324.        INTEGER JSTR(1322),CSTR(1322),SPTR,SNUM,TSNUM,
  2325.      +          COM(25),DOVAR(7),TRMLBL(6),DUMMY(2),CONONE(2),
  2326.      +          JUNK(7),KM1STR(4),NUM1,NUM4,VALC,NRDIG,PONE(1322),
  2327.      +          DNODES(200,10),NRDEPS(10),LHSNOD,
  2328.      +          BLKMEM,LHSMEM,NRRANG,VALK,KSTR(1322),KNOD
  2329.  
  2330.        INTEGER LENGTH,ZYNEXT,NODETP,INDJPK,CTOI,ITOC,
  2331.      +          EQUAL,JPMC1,COMPAR,ZYDOWN,ZYPREV
  2332.  
  2333.        EXTERNAL GETIL,COMOUT,LENGTH,ZTOKWR,YSTMT,
  2334.      +           ZYNEXT,NODETP,GETSTR,INDJPK,
  2335.      +           CTOI,ITOC,EQUAL,JPMC1,COMPAR,ZYDOWN,
  2336.      +           ZYPREV
  2337.  
  2338. C---------------------------------------------------------
  2339. C    TOOLPACK/1    Release: 2.1
  2340. C---------------------------------------------------------
  2341. C
  2342. C  TKLAST = LAST TOKEN NUMBER
  2343. C
  2344.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  2345.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  2346.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  2347.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  2348.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  2349.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  2350.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  2351.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  2352.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  2353.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  2354.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  2355.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  2356.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  2357.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  2358.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  2359.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  2360.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  2361.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  2362.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  2363.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  2364.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  2365.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  2366.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  2367.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  2368.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  2369.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  2370.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  2371.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  2372.  
  2373.  
  2374.        DATA DUMMY(1)/129/
  2375.        DATA CONONE/49,129/
  2376.  
  2377.        DATA COM/67,42,42,42,32,80,101,101,108,
  2378.      +           105,110,103,32,97,112,112,108,105,
  2379.      +           101,100,32,42,42,42,129/
  2380.  
  2381. C If there are no assignment statements preceding the DO, the paradigm
  2382. C does not match.
  2383.        IF (NRBLK .EQ. 0) THEN
  2384.           SIC = .FALSE.
  2385.           RETURN
  2386.        END IF
  2387.  
  2388. C E3 must be 0.
  2389.        IF (E3 .NE. 0) THEN
  2390.           SIC = .FALSE.
  2391.           RETURN
  2392.        END IF
  2393.  
  2394. C Is xpr(E1) = 1?
  2395.        IF (ZYDOWN(E1) .GE. 0) THEN
  2396.           SIC = .FALSE.
  2397.           RETURN
  2398.        END IF
  2399.  
  2400.        CALL GETSTR(E1,PONE)
  2401.        IF (EQUAL(PONE,CONONE) .NE. -2) THEN
  2402.           SIC = .FALSE.
  2403.           RETURN
  2404.        END IF
  2405.  
  2406. C Does xpr(E2) have form (J + c) - 1?
  2407.        IF (JPMC1(E2,JSTR,1,CSTR,0) .EQ. -3) THEN
  2408.           SIC = .FALSE.
  2409.           RETURN
  2410.        END IF
  2411.  
  2412. C The DO parameters match the paradigm.
  2413. C Calculate the value of c = VALC.
  2414.        NUM1 = 1
  2415.        VALC = CTOI(CSTR,NUM1)
  2416.  
  2417. C Determine the dependency sets of statements in the DO range.
  2418.        SPTR = FIRST
  2419.        NRRANG = 1
  2420. 100       CONTINUE
  2421.        CALL DEPSET(SPTR,DNODES(1,NRRANG),NRDEPS(NRRANG))
  2422.        IF (SPTR .NE. LAST) THEN
  2423.           SPTR = ZYNEXT(SPTR)
  2424.           NRRANG = NRRANG + 1
  2425.           IF (NRRANG .GT. 10) CALL ERROR('ICOD2: Second '
  2426.      +         //'Dimension Of DNODES = Dimension Of NRDEPS '
  2427.      +         //'Is Too Small.')
  2428.           GO TO 100
  2429.        END IF
  2430.  
  2431. C Examine each statement in the block of assignment statements for
  2432. C conformance to the paradigm.
  2433.        BLKMEM = BEGBLK
  2434.        DO 80 I = 1,NRBLK
  2435.  
  2436. C Is every index in the statement of form J+k where k .ge. 0?
  2437.           IF(INDJPK(BLKMEM,JSTR) .EQ. -3) THEN
  2438.              SIC = .FALSE.
  2439.              RETURN
  2440.           END IF
  2441.  
  2442. C Is the lhs an array element (after outer parentheses are removed)?
  2443.           LHSMEM = ZYDOWN(BLKMEM)
  2444.           IF (NODETP(LHSMEM) .EQ. 115) LHSMEM = ZYNEXT(LHSMEM)
  2445. 90          CONTINUE
  2446.           IF (NODETP(LHSMEM) .EQ. 101) THEN
  2447.              LHSMEM = ZYDOWN(LHSMEM)
  2448.              GO TO 90
  2449.           END IF
  2450.           IF (NODETP(LHSMEM) .NE. 104) THEN
  2451.              SIC = .FALSE.
  2452.              RETURN
  2453.           ELSE
  2454. C The lhs is an array element and we know from the previous check
  2455. C that its indices are of form J+k.  Check that there is only one index
  2456. C and evaluate k.  There are two cases: k=0 and k .gt. 0.
  2457.              KNOD = ZYNEXT(ZYDOWN(LHSMEM))
  2458.              IF (NODETP(KNOD) .EQ. 108) THEN
  2459.                 IF (ZYNEXT(KNOD) .GT. 0) THEN
  2460.                    SIC = .FALSE.
  2461.                    RETURN
  2462.                 END IF
  2463.                 VALK = 0
  2464.              ELSE IF (NODETP(KNOD) .EQ. 95) THEN
  2465.                 IF (ZYNEXT(KNOD) .GT. 0) THEN
  2466.                    SIC = .FALSE.
  2467.                    RETURN
  2468.                 END IF
  2469.                 KNOD = ZYNEXT(ZYDOWN(KNOD))
  2470.                 CALL GETSTR(KNOD,KSTR)
  2471.                 NUM1 = 1
  2472.                 VALK = CTOI(KSTR,NUM1)
  2473.              ELSE
  2474. C This branch should never be taken!
  2475.                 CALL ERROR('ICOD2: Internal Error 1.')
  2476.              END IF
  2477.           END IF
  2478.  
  2479. C Is k < c?
  2480.           IF (VALK .GE. VALC) THEN
  2481.              SIC = .FALSE.
  2482.              RETURN
  2483.           END IF
  2484.  
  2485. C Is the statement an assignment to a member of the dependency
  2486. C set of a statement in the DO range?
  2487.           DO 110 K = 1,NRRANG
  2488.              DO 120 J = 1,NRDEPS(K)
  2489.                 IF (COMPAR(LHSMEM,DNODES(J,K)) .EQ. -2) THEN
  2490.                    SIC = .FALSE.
  2491.                    RETURN
  2492.                 END IF
  2493. 120             CONTINUE
  2494. 110          CONTINUE
  2495.           BLKMEM = ZYNEXT(BLKMEM)
  2496. 80       CONTINUE
  2497.  
  2498. C Is every statement in the range of the DO an assignment for which the
  2499. C lhs is an array element whose indices are the DO variable?
  2500.        SPTR = FIRST
  2501. 40       CONTINUE
  2502. C Assignment?
  2503.        IF (NODETP(SPTR) .NE. 49) THEN
  2504.           SIC = .FALSE.
  2505.           RETURN
  2506.        END IF
  2507.  
  2508. C Array Element?
  2509.        LHSNOD = ZYDOWN(SPTR)
  2510.        IF (NODETP(LHSNOD) .EQ. 115) LHSNOD = ZYNEXT(LHSNOD)
  2511.        IF (NODETP(LHSNOD) .NE. 104) THEN
  2512.           SIC = .FALSE.
  2513.           RETURN
  2514.        END IF
  2515.  
  2516. C Each index is the DO variable (remove parentheses before checking)?
  2517.        LHSNOD = ZYNEXT(ZYDOWN(LHSNOD))
  2518. 60       CONTINUE
  2519.        IF (NODETP(LHSNOD) .EQ. 101) THEN
  2520.           LHSNOD = ZYDOWN(LHSNOD)
  2521.           GO TO 60
  2522.        END IF
  2523.        IF (COMPAR(LHSNOD,VARNOD) .NE. -2) THEN
  2524.           SIC = .FALSE.
  2525.           RETURN
  2526.        END IF
  2527.        LHSNOD = ZYNEXT(LHSNOD)
  2528.        IF (LHSNOD .NE. 0) GO TO 60
  2529.  
  2530.        IF (SPTR .NE. LAST) THEN
  2531.           SPTR = ZYNEXT(SPTR)
  2532.           GO TO 40
  2533.        END IF
  2534.  
  2535. C The paradigm is satisfied.  Output the transformed code.
  2536. C First output comment that peeling being applied.
  2537.        CALL ZTOKWR(TCMMNT,LENGTH(COM),COM,TKNCHN)
  2538.        CALL ZMESS('Paradigm PAD.',2)
  2539.        SIC = .TRUE.
  2540.        SNUM = NUMF
  2541.  
  2542. C Convert the DO variable to a string.
  2543.        CALL GETSTR(VARNOD,DOVAR)
  2544.  
  2545. C Generate a new termination label for convenience.
  2546.        CALL GETIL(JUNK,TRMLBL)
  2547.  
  2548. C Output the DO statement with x(E2) changed to J - 1.
  2549. C DO
  2550.         CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
  2551. C termination label reference
  2552.         CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
  2553. C DO variable
  2554.         CALL ZTOKWR(TNAME,LENGTH(DOVAR),DOVAR,TKNCHN)
  2555. C =
  2556.         CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
  2557. C 1
  2558.         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  2559. C ,
  2560.         CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  2561. C JSTR
  2562.         CALL ZTOKWR(TNAME,LENGTH(JSTR),JSTR,TKNCHN)
  2563. C -
  2564.         CALL ZTOKWR(TMINUS,0,DUMMY(1),TKNCHN)
  2565. C 1
  2566.         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  2567. C end-of-statement (modified DO)
  2568.         CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  2569.  
  2570. C Adjust the statement pointer by the number of statements in buffer.
  2571.        TSNUM = SNUM + NRBLK
  2572.        TSNUM = TSNUM + 1
  2573.        CALL COMOUT(TSNUM)
  2574.  
  2575. C Write the range
  2576.        SPTR = FIRST
  2577. 20       CONTINUE
  2578.        CALL YSTMT(SPTR,TKNCHN)
  2579.        TSNUM = TSNUM + 1
  2580.        CALL COMOUT(TSNUM)
  2581.        IF (SPTR .NE. LAST) THEN
  2582.           SPTR = ZYNEXT(SPTR)
  2583.           GO TO 20
  2584.        END IF
  2585. C Write the terminating CONTINUE.
  2586. C Terminating label
  2587.        CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
  2588. C CONTINUE
  2589.        CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
  2590. C end-of-statement (CONTINUE statement)
  2591.        CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  2592.        TSNUM = TSNUM + 1
  2593.        CALL COMOUT(TSNUM)
  2594.  
  2595. C Output the assignment statements in the buffer.
  2596.        BLKMEM = BEGBLK
  2597.        DO 500 I = 1,NRBLK
  2598.            CALL YSTMT(BLKMEM,TKNCHN)
  2599.           SNUM = SNUM + 1
  2600.           CALL COMOUT(SNUM)
  2601.           BLKMEM = ZYNEXT(BLKMEM)
  2602. 500       CONTINUE
  2603.  
  2604. C Output the range of the DO c times.  On the nth repetition,
  2605. C substitute J + (n-1) for the DO variable.
  2606.  
  2607.        DO 600 K = 1,VALC
  2608. C Convert the value of K-1 to the string KM1STR.
  2609.           NUM4 = 4
  2610.           NRDIG = ITOC(K-1,KM1STR,NUM4)
  2611.  
  2612.           SPTR = FIRST
  2613. 10          CONTINUE
  2614.            CALL UASGN(SPTR,DOVAR,JSTR,KM1STR,0,TKNCHN)
  2615.           IF (SPTR .NE. LAST) THEN
  2616.              SPTR = ZYNEXT(SPTR)
  2617.              GO TO 10
  2618.           END IF
  2619. 600       CONTINUE
  2620.  
  2621. C Set flag to repeat ISTCD.
  2622.        ITERAT = .TRUE.
  2623.  
  2624.        NUML = TSNUM
  2625.  
  2626.        END
  2627. C-----------------------   ICOD3.MAC
  2628. C ---------------------------------------------------------------------
  2629. C          I C O D 3 - Test whether a DO and its immediately following
  2630. C                     two statements are such as would be generated
  2631. C                      by the peeling in P4AJAK; i.e., following assignment
  2632. C                     statements are the result of the peeling followed
  2633. C                     by a DO satisfying the conditions of
  2634. C                     P4AJAK.  If these conditions hold, move
  2635. C                      the assignments and condense the DOs.  NXTNOD = 0
  2636. C                     if the conditions fail and no action taken; otherwise,
  2637. C                     NXTNOD is the node following the second DO.
  2638. C
  2639.        SUBROUTINE ICOD3(VARNOD,E1,E2,E3,FIRST,LAST,NUMF,NUML,NXTNOD)
  2640.  
  2641.        INTEGER VARNOD,E1,E2,E3,FIRST,LAST,NUMF,NUML,NXTNOD
  2642.  
  2643.       COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  2644.       INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  2645.         SAVE
  2646.         INTEGER I, J, K, INDNOD
  2647.  
  2648. C---------------------------------------------------------
  2649. C    TOOLPACK/1    Release: 2.1
  2650. C---------------------------------------------------------
  2651. C
  2652. C THIS IS USED BY BOTH ISTSB AND ISTCD
  2653. C
  2654. C This COMMON block contains the logical variable ITERAT which is
  2655. C set to .TRUE. when a condition is encountered that implies that
  2656. C further processing is required on the parse tree obtained from
  2657. C the token stream output from the current run.  ZQUIT is called
  2658. C with condition 'repeat' if and only if ITERAT is .TRUE.
  2659. C
  2660. C This COMMON block contains the logical variables ITERAT and CYCLE.
  2661.  
  2662.       COMMON /REPEAT/ ITERAT,CYCLE
  2663.       LOGICAL ITERAT,CYCLE
  2664.  
  2665.        INTEGER SPTR,SNUM,COM(53),DOVAR1(7),TRMLBL(6),DUMMY(2),
  2666.      +          DNODES(200,10),NRDEPS(10),LHSNOD,JUNK1,JUNK2,DOVAR2(7),
  2667.      +          LHSSTM,NRRANG,DOSTM,EE1(2),EE2(2),EE3(2),
  2668.      +          FIRST2,LAST2,CONST(1322),VCONST,JSTR1(10),
  2669.      +          JSTR2(10),CSTR1(10),CSTR2(10),CONONE(2),JUNK(7),NUM1,
  2670.      +          BEGBLK,ASNSTM,NRBLK
  2671.  
  2672.        LOGICAL LOGJNK
  2673.  
  2674.        INTEGER LENGTH,ZYNEXT,NODETP,INDJP1,INDJPK,CTOI,ITOC,
  2675.      +          EQUAL,JPMC1,INDJM1,COMPAR,ZYDOWN,ZYPREV
  2676.  
  2677.        EXTERNAL GETIL,YEXPR,COMOUT,LENGTH,ZTOKWR,YSTMT,
  2678.      +           ZYNEXT,CHKEQV,NODETP,GETSTR,INDJP1,INDJPK,
  2679.      +           CTOI,ITOC,EQUAL,JPMC1,INDJM1,COMPAR,ZYDOWN,
  2680.      +           ZYPREV
  2681.  
  2682. C---------------------------------------------------------
  2683. C    TOOLPACK/1    Release: 2.1
  2684. C---------------------------------------------------------
  2685. C
  2686. C  TKLAST = LAST TOKEN NUMBER
  2687. C
  2688.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  2689.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  2690.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  2691.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  2692.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  2693.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  2694.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  2695.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  2696.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  2697.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  2698.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  2699.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  2700.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  2701.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  2702.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  2703.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  2704.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  2705.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  2706.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  2707.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  2708.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  2709.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  2710.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  2711.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  2712.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  2713.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  2714.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  2715.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  2716.  
  2717.  
  2718.        DATA DUMMY(1)/129/
  2719.        DATA CONONE/49,129/
  2720.  
  2721. C "C*** Intervening statements moved - DOs combined ***"
  2722.        DATA COM/67,42,42,42,32,73,110,116,101,
  2723.      +  114,118,101,110,105,110,103,32,115,116,97,
  2724.      +  116,101,109,101,110,116,115,32,109,111,118,101,
  2725.      +  100,32,45,32,68,79,115,32,99,111,
  2726.      +  109,98,105,110,101,100,32,42,42,42,129/
  2727.  
  2728. C Get the block of assignment statements following the DO.  The
  2729. C first is BEGBLK and there are NRBLK assignment statements.
  2730.        NRBLK = 0
  2731.        BEGBLK = ZYNEXT(ZYNEXT(LAST))
  2732.        ASNSTM = BEGBLK
  2733. 50       CONTINUE
  2734.        IF (NODETP(ASNSTM) .EQ. 49) THEN
  2735.           NRBLK = NRBLK + 1
  2736.           ASNSTM = ZYNEXT(ASNSTM)
  2737.           GO TO 50
  2738.        END IF
  2739.  
  2740. C Is the assignment block non-null?
  2741.        IF (NRBLK .EQ. 0) THEN
  2742.           NXTNOD = 0
  2743.           RETURN
  2744.        END IF
  2745.  
  2746. C Is the statement after the last assignment a DO?
  2747.        DOSTM = ASNSTM
  2748.        IF (NODETP(DOSTM) .NE. 61) THEN
  2749.           NXTNOD = 0
  2750.           RETURN
  2751.        END IF
  2752.  
  2753. C Are the DOs E1,E2 equivalent in the sense of P4AJAK; i.e., xpr(E1)=1,
  2754. C xpr(E2) = (J-k)-1 for some k .ge. 0, E3 default?
  2755.  
  2756.        CALL DOPROP(ZYPREV(FIRST),DOVAR1,EE1(1),EE2(1),EE3(1),JUNK1,
  2757.      +              JUNK2)
  2758.        CALL DOPROP(DOSTM,DOVAR2,EE1(2),EE2(2),EE3(2),FIRST2,LAST2)
  2759.  
  2760. C xpr(E3) default for both DOs?
  2761.        IF ((EE3(1) .NE. 0) .OR. (EE3(2) .NE. 0)) THEN
  2762.           NXTNOD = 0
  2763.           RETURN
  2764.        END IF
  2765.  
  2766. C xpr(E1) = 1 for both DOs?
  2767.        DO 10 I = 1,2
  2768.           IF (NODETP(EE1(I)) .NE. 107) THEN
  2769.              NXTNOD = 0
  2770.              RETURN
  2771.           END IF
  2772.  
  2773.           CALL GETSTR(EE1(I),CONST)
  2774.           NUM1 = 1
  2775.           VCONST = CTOI(CONST,NUM1)
  2776.           IF (VCONST .NE. 1) THEN
  2777.              NXTNOD = 0
  2778.              RETURN
  2779.           END IF
  2780. 10       CONTINUE
  2781.  
  2782. C Check the condition on the E2 nodes.
  2783.  
  2784.        IF (JPMC1(EE2(1),JSTR1,0,CSTR1,0) .EQ. -3) THEN
  2785.           NXTNOD = 0
  2786.           RETURN
  2787.        END IF
  2788.        IF (JPMC1(EE2(2),JSTR2,0,CSTR2,0) .EQ. -3) THEN
  2789.           NXTNOD = 0
  2790.           RETURN
  2791.        END IF
  2792.  
  2793.        IF (COMPAR(EE2(1),EE2(2)) .EQ. -3) THEN
  2794.           NXTNOD = 0
  2795.           RETURN
  2796.        END IF
  2797.  
  2798. C Determine the dependency sets of statements in the range
  2799. C of the first DO.
  2800.        SPTR = FIRST
  2801.        NRRANG = 1
  2802. 100       CONTINUE
  2803.        CALL DEPSET(SPTR,DNODES(1,NRRANG),NRDEPS(NRRANG))
  2804.        IF (SPTR .NE. LAST) THEN
  2805.           SPTR = ZYNEXT(SPTR)
  2806.           NRRANG = NRRANG + 1
  2807.           IF (NRRANG .GT. 10) CALL ERROR('ICOD3: Second '
  2808.      +         //'Dimension Of DNODES = Dimension Of NRDEPS '
  2809.      +         //'Is Too Small.')
  2810.           GO TO 100
  2811.        END IF
  2812.  
  2813. C Examine each statement in the assignment block following the first DO.
  2814.  
  2815.        ASNSTM = BEGBLK
  2816.        DO 2000 I = 1,NRBLK
  2817.  
  2818. C Is every index in the statement of form J-k where 0 .le. k .le. c?
  2819.           IF(INDJM1(ASNSTM,JSTR1,CSTR1,LOGJNK) .EQ. -3) THEN
  2820.              NXTNOD = 0
  2821.              RETURN
  2822.           END IF
  2823.  
  2824. C Is the lhs an array element (after outer parentheses are removed)?
  2825.           LHSSTM = ZYDOWN(ASNSTM)
  2826.           IF (NODETP(LHSSTM) .EQ. 115) LHSSTM = ZYNEXT(LHSSTM)
  2827. 90          CONTINUE
  2828.           IF (NODETP(LHSSTM) .EQ. 101) THEN
  2829.              LHSSTM = ZYDOWN(LHSSTM)
  2830.              GO TO 90
  2831.           END IF
  2832.           IF (NODETP(LHSSTM) .NE. 104) THEN
  2833.              NXTNOD = 0
  2834.              RETURN
  2835.           END IF
  2836.  
  2837. C Is the statement an assignment to a member of the dependency
  2838. C set of a statement in the DO range?
  2839.           DO 110 K = 1,NRRANG
  2840.              DO 120 J = 1,NRDEPS(K)
  2841.                 IF (COMPAR(LHSSTM,DNODES(J,K)) .EQ. -2) THEN
  2842.                    NXTNOD = 0
  2843.                    RETURN
  2844.                 END IF
  2845. 120             CONTINUE
  2846. 110          CONTINUE
  2847.  
  2848.           ASNSTM = ZYNEXT(ASNSTM)
  2849. 2000       CONTINUE
  2850.  
  2851. C Is every statement in the range of the DO an assignment for which the
  2852. C lhs is an array element whose indices are the DO variable?
  2853.        SPTR = FIRST
  2854. 40       CONTINUE
  2855. C Assignment?
  2856.        IF (NODETP(SPTR) .NE. 49) THEN
  2857.           NXTNOD = 0
  2858.           RETURN
  2859.        END IF
  2860.  
  2861. C Array Element?
  2862.        LHSNOD = ZYDOWN(SPTR)
  2863.        IF (NODETP(LHSNOD) .EQ. 115) LHSNOD = ZYNEXT(LHSNOD)
  2864.        IF (NODETP(LHSNOD) .NE. 104) THEN
  2865.           NXTNOD = 0
  2866.           RETURN
  2867.        END IF
  2868.  
  2869. C Each index is the DO variable (remove parentheses before checking)?
  2870.        INDNOD = ZYNEXT(ZYDOWN(LHSNOD))
  2871. 60       CONTINUE
  2872.        IF (NODETP(INDNOD) .EQ. 101) THEN
  2873.           INDNOD = ZYDOWN(INDNOD)
  2874.           GO TO 60
  2875.        END IF
  2876.        IF (COMPAR(INDNOD,VARNOD) .NE. -2) THEN
  2877.           NXTNOD = 0
  2878.           RETURN
  2879.        END IF
  2880.        INDNOD = ZYNEXT(INDNOD)
  2881.        IF (INDNOD .NE. 0) GO TO 60
  2882.  
  2883.        IF (SPTR .NE. LAST) THEN
  2884.           SPTR = ZYNEXT(SPTR)
  2885.           GO TO 40
  2886.        END IF
  2887.  
  2888. C The conditions are satisfied.  Output the transformed code.
  2889. C First output comment that transformation being applied.
  2890.        CALL ZTOKWR(TCMMNT,LENGTH(COM),COM,TKNCHN)
  2891.        CALL ZMESS('Continue Paradigm PJK.',2)
  2892.        NXTNOD = ZYNEXT(ZYNEXT(LAST2))
  2893.        SNUM = NUMF
  2894.  
  2895. C Output the assignment block.
  2896.        ASNSTM = BEGBLK
  2897.        DO 2100 I = 1,NRBLK
  2898.           CALL YSTMT(ASNSTM,TKNCHN)
  2899.           ASNSTM = ZYNEXT(ASNSTM)
  2900. 2100       CONTINUE
  2901.  
  2902. C Generate a new termination label for convenience.
  2903.        CALL GETIL(JUNK,TRMLBL)
  2904.  
  2905. C Output the DO statement for the condensed DO.
  2906. C DO
  2907.         CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
  2908. C termination label reference
  2909.         CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
  2910. C DO variable
  2911.         CALL ZTOKWR(TNAME,LENGTH(DOVAR1),DOVAR1,TKNCHN)
  2912. C =
  2913.         CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
  2914. C 1
  2915.         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  2916. C ,
  2917.         CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  2918. C E2
  2919.        CALL YEXPR(EE2(1),TKNCHN)
  2920. C end-of-statement (DO)
  2921.         CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  2922.  
  2923.        SNUM = SNUM + 1
  2924.        CALL COMOUT(SNUM)
  2925.  
  2926. C Write the range of the first DO.
  2927.        SPTR = FIRST
  2928. 20       CONTINUE
  2929.        CALL YSTMT(SPTR,TKNCHN)
  2930.        SNUM = SNUM + 1
  2931.        CALL COMOUT(SNUM)
  2932.        IF (SPTR .NE. LAST) THEN
  2933.           SPTR = ZYNEXT(SPTR)
  2934.           GO TO 20
  2935.        END IF
  2936.  
  2937.        SNUM = SNUM + NRBLK + 2
  2938.  
  2939. C Write the range of the second DO.
  2940.        SPTR = FIRST2
  2941. 30       CONTINUE
  2942.        CALL YSTMT(SPTR,TKNCHN)
  2943.        SNUM = SNUM + 1
  2944.        CALL COMOUT(SNUM)
  2945.        IF (SPTR .NE. LAST2) THEN
  2946.           SPTR = ZYNEXT(SPTR)
  2947.           GO TO 30
  2948.        END IF
  2949.  
  2950. C Write the terminating CONTINUE.
  2951. C Terminating label
  2952.        CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
  2953. C CONTINUE
  2954.        CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
  2955. C end-of-statement (CONTINUE statement)
  2956.        CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  2957.        SNUM = SNUM + 1
  2958.        CALL COMOUT(SNUM)
  2959.  
  2960. C Set flag to repeat ISTYP/ISTCD
  2961.        ITERAT = .TRUE.
  2962.  
  2963.        NUML = SNUM
  2964.  
  2965.        END
  2966. C-----------------------   JPMC.MAC
  2967. C ---------------------------------------------------------------------
  2968. C            J P M C - Test whether xpr(NODE) is of the form J or J+c or J-c
  2969. C                   (with outer parentheses removed) for integer c .ge. 1.
  2970. C                   Return 'yes' or 'no'. If 'yes', return J as a string
  2971. C                   (JSTR), c as a string (CSTR), and PLUS as 0,1,or -1
  2972. C                         for the cases J, J+c, J-c respectively.  CSTR is
  2973. C                         returned as dig0,eos when PLUS = 0.
  2974. C
  2975.       INTEGER FUNCTION JPMC(NODE,JSTR,CSTR,PLUS)
  2976.  
  2977.       INTEGER NODE,JSTR(*),CSTR(*),PLUS
  2978.  
  2979.       INTEGER CONZER(2),NPNOD,POSSJ,POSSC,TYPE
  2980.  
  2981.       INTEGER ZYNEXT,NODETP,ZYDOWN
  2982.       EXTERNAL ZYNEXT,NODETP,GETSTR,ZYDOWN,SCOPY
  2983.  
  2984.  
  2985.       DATA CONZER/48,129/
  2986.  
  2987. C Remove outer parentheses for comparison.
  2988.       NPNOD = NODE
  2989. 10      CONTINUE
  2990.       IF (NODETP(NPNOD) .EQ. 101) THEN
  2991.          NPNOD = ZYDOWN(NPNOD)
  2992.          GO TO 10
  2993.       END IF
  2994.  
  2995.       TYPE = NODETP(NPNOD)
  2996.       IF (TYPE .EQ. 95) THEN
  2997.          PLUS = 1
  2998.       ELSE IF (TYPE .EQ. 96) THEN
  2999.          PLUS = -1
  3000.       ELSE IF (TYPE .EQ. 108) THEN
  3001.          PLUS = 0
  3002.          CALL GETSTR(NPNOD,JSTR)
  3003.          CALL SCOPY(CONZER,1,CSTR,1)
  3004.          JPMC = -2
  3005.          RETURN
  3006.       ELSE
  3007.          JPMC = -3
  3008.          RETURN
  3009.       END IF
  3010.  
  3011. C Node is of type N_PLUS or N_MINUS.
  3012.  
  3013. C J+ or J-?
  3014.       POSSJ = ZYDOWN(NPNOD)
  3015.       IF (NODETP(POSSJ) .EQ. 108) THEN
  3016.          CALL GETSTR(POSSJ,JSTR)
  3017.       ELSE
  3018.          JPMC = -3
  3019.          RETURN
  3020.       END IF
  3021.  
  3022. C J+c or J-c?
  3023.       POSSC = ZYNEXT(POSSJ)
  3024.       IF (NODETP(POSSC) .EQ. 107) THEN
  3025.          CALL GETSTR(POSSC,CSTR)
  3026.          JPMC = -2
  3027.          RETURN
  3028.       ELSE
  3029.          JPMC = -3
  3030.          RETURN
  3031.       END IF
  3032.  
  3033.       END
  3034. C-----------------------   JPMC1.MAC
  3035. C ---------------------------------------------------------------------
  3036. C         J P M C 1  - Test whether xpr(NODE) is of the form (J & c) & 1
  3037. C                   (with outer parentheses removed) where
  3038. C                   '&' is '+' or '-' as A and B are 1 or 0 respectively.
  3039. C                   Return 'yes' or 'no'. If 'yes', return
  3040. C                   J as a string and c as a string.
  3041. C                         The case J & 1 is handled as a special case and
  3042. C                         c is returned as dig0,eos.
  3043. C
  3044.       INTEGER FUNCTION JPMC1(NODE,JSTR,A,CSTR,B)
  3045.  
  3046.       INTEGER NODE,JSTR(*),A,CSTR(*),B
  3047.  
  3048.       INTEGER CONONE(2),PONE(1322),POINTR,PLUS,ATYPE,BTYPE
  3049.  
  3050.       INTEGER ZYNEXT,NODETP,ZYDOWN,EQUAL,JPMC
  3051.       EXTERNAL ZYNEXT,NODETP,GETSTR,ZYDOWN,EQUAL,JPMC
  3052.  
  3053.  
  3054.       DATA CONONE/49,129/
  3055.  
  3056. C Derive node types from A and B.
  3057.       IF (A .EQ. 1) THEN
  3058.          ATYPE = 95
  3059.       ELSE IF (A .EQ. 0) THEN
  3060.          ATYPE = 96
  3061.       ELSE
  3062.          CALL ERROR('ISTCD: Third Argument must be 0 124 1.')
  3063.       END IF
  3064.       IF (B .EQ. 1) THEN
  3065.          BTYPE = 95
  3066.       ELSE IF (B .EQ. 0) THEN
  3067.          BTYPE = 96
  3068.       ELSE
  3069.          CALL ERROR('ISTCD: Fifth Argument must be 0 124 1.')
  3070.       END IF
  3071.  
  3072. C Remove outer parentheses for comparison.
  3073.       POINTR = NODE
  3074. 10      CONTINUE
  3075.       IF (NODETP(POINTR) .EQ. 101) THEN
  3076.          POINTR = ZYDOWN(POINTR)
  3077.          GO TO 10
  3078.       END IF
  3079.  
  3080.       IF (NODETP(POINTR) .NE. BTYPE) THEN
  3081.          JPMC1 = -3
  3082.          RETURN
  3083.       END IF
  3084.  
  3085.       POINTR = ZYDOWN(POINTR)
  3086.       IF (JPMC(POINTR,JSTR,CSTR,PLUS) .EQ. -3) THEN
  3087.          JPMC1 = -3
  3088.          RETURN
  3089.       END IF
  3090.  
  3091.       IF ((PLUS .EQ. 1 .AND. ATYPE .EQ. 96) .OR.
  3092.      +      (PLUS .EQ. -1 .AND. ATYPE .EQ. 95)) THEN
  3093.          JPMC1 = -3
  3094.          RETURN
  3095.       END IF
  3096.  
  3097.       POINTR = ZYNEXT(POINTR)
  3098.       IF (NODETP(POINTR) .NE. 107) THEN
  3099.          JPMC1 = -3
  3100.          RETURN
  3101.       END IF
  3102.  
  3103.       CALL GETSTR(POINTR,PONE)
  3104.       IF (EQUAL(PONE,CONONE) .NE. -2) THEN
  3105.          JPMC1 = -3
  3106.          RETURN
  3107.       END IF
  3108.  
  3109.       JPMC1 = -2
  3110.  
  3111.       END
  3112. C-----------------------   P4AJAK.MAC
  3113. C ---------------------------------------------------------------------
  3114. C             P4AJAK - Test whether a consequtive pair of DOs
  3115. C                   satisfy certain necessary conditions for
  3116. C                     the f04aj or f04ak paradigms; if so,
  3117. C                     peel the last iteration from the
  3118. C                     first DO.  The transformation will be
  3119. C                     completed by ICOD3 which, in turn, results
  3120. C                     in E1,E2 equivalence.
  3121. C
  3122.       SUBROUTINE P4AJAK(VAR,E1,E2,E3,FIRST,LAST,NRDOS,NUMF,NUML,HOLD)
  3123.  
  3124.       INTEGER VAR(7),E1(50),E2(50),E3,FIRST(50),LAST(50),NRDOS,
  3125.      +          NUMF,NUML
  3126.       LOGICAL HOLD
  3127.  
  3128.         COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  3129.         INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  3130.         SAVE
  3131. C---------------------------------------------------------
  3132. C    TOOLPACK/1    Release: 2.1
  3133. C---------------------------------------------------------
  3134. C
  3135. C THIS IS USED BY BOTH ISTSB AND ISTCD
  3136. C
  3137. C This COMMON block contains the logical variable ITERAT which is
  3138. C set to .TRUE. when a condition is encountered that implies that
  3139. C further processing is required on the parse tree obtained from
  3140. C the token stream output from the current run.  ZQUIT is called
  3141. C with condition 'repeat' if and only if ITERAT is .TRUE.
  3142. C
  3143. C This COMMON block contains the logical variables ITERAT and CYCLE.
  3144.  
  3145.       COMMON /REPEAT/ ITERAT,CYCLE
  3146.       LOGICAL ITERAT,CYCLE
  3147.  
  3148.       INTEGER I,TRMLBL(6),DUMMY(2),SNUM,POINTR,JUNK(7),
  3149.      +          CONST(1322),VCONST,NPE2(2),COM(25),
  3150.      +          NUM1,CONONE(2),JSTR1(10),JSTR2(10),CSTR1(10),
  3151.      +          CSTR2(10),VAL1,VAL2
  3152.  
  3153.       INTEGER LENGTH,ZYNEXT,CTOI,NODETP,ZYDOWN,ZYPREV,
  3154.      +          JPMC1,EQUAL,ITOC
  3155.  
  3156.       EXTERNAL GETIL,YEXPR,COMOUT,LENGTH,ZTOKWR,YSTMT,
  3157.      +           ZYNEXT,CHKEQV,CTOI,NODETP,GETSTR,ZYDOWN,ZYPREV,
  3158.      +           JPMC1,EQUAL,UASGN,ITOC
  3159.  
  3160. C---------------------------------------------------------
  3161. C    TOOLPACK/1    Release: 2.1
  3162. C---------------------------------------------------------
  3163. C
  3164. C  TKLAST = LAST TOKEN NUMBER
  3165. C
  3166.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  3167.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  3168.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  3169.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  3170.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  3171.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  3172.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  3173.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  3174.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  3175.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  3176.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  3177.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  3178.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  3179.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  3180.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  3181.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  3182.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  3183.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  3184.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  3185.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  3186.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  3187.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  3188.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  3189.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  3190.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  3191.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  3192.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  3193.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  3194.  
  3195.  
  3196. C "C*** Peeling Applied ***"
  3197.       DATA COM/67,42,42,42,32,80,101,101,108,
  3198.      +           105,110,103,32,97,112,112,108,105,
  3199.      +           101,100,32,42,42,42,129/
  3200.  
  3201.       DATA DUMMY(1)/129/
  3202.       DATA CONONE/49,129/
  3203.       SNUM = NUMF
  3204.  
  3205. C Test the first two DOs in the sequence for a set of necessary
  3206. C conditions associated with the f04aj,f04ak paradigm, namely, The two
  3207. C DOs must have xpr(E3) default or 1, xpr(E1)=1, and the first and second
  3208. C xpr(E2)s must be of form
  3209. C
  3210. C            (J-c1)-1, (J-c2)-1 where c2 = c1+1.
  3211. C
  3212. C for some J where where c1,c2 .ge. 0.  If c1=0, the forms are
  3213. C
  3214. C            J-1,(J-1)-1.
  3215. C Finally, every statement in the range of the first DO must be an
  3216. C assignment.
  3217.  
  3218. C HOLD will be set to .TRUE. if the conditions hold.
  3219.       HOLD = .FALSE.
  3220.  
  3221. C xpr(E3) default or 1?
  3222.       IF (E3 .NE. 0) THEN
  3223.          IF (NODETP(E3) .NE. 107) THEN
  3224.             HOLD = .FALSE.
  3225.             RETURN
  3226.          END IF
  3227.  
  3228.          CALL GETSTR(E3,CONST)
  3229.          NUM1 = 1
  3230.          VCONST = CTOI(CONST,NUM1)
  3231.          IF (VCONST .NE. 1) THEN
  3232.             HOLD = .FALSE.
  3233.             RETURN
  3234.          END IF
  3235.       END IF
  3236.  
  3237. C xpr(E1) = 1 for both DOs?
  3238.       DO 10 I = 1,2
  3239.          IF (NODETP(E1(I)) .NE. 107) THEN
  3240.             HOLD = .FALSE.
  3241.             RETURN
  3242.          END IF
  3243.  
  3244.          CALL GETSTR(E1(I),CONST)
  3245.          NUM1 = 1
  3246.          VCONST = CTOI(CONST,NUM1)
  3247.          IF (VCONST .NE. 1) THEN
  3248.             HOLD = .FALSE.
  3249.             RETURN
  3250.          END IF
  3251. 10      CONTINUE
  3252.  
  3253. C Check the condition on the E2 nodes.  Remove outer parenthesis
  3254. C for comparison.
  3255.       DO 400 I=1,2
  3256.          NPE2(I) = E2(I)
  3257. 1200         CONTINUE
  3258.          IF (NODETP(NPE2(I)) .EQ. 101) THEN
  3259.             NPE2(I) = ZYDOWN(NPE2(I))
  3260.             GO TO 1200
  3261.          END IF
  3262. 400      CONTINUE
  3263.  
  3264.       IF (JPMC1(NPE2(1),JSTR1,0,CSTR1,0) .EQ. -3) THEN
  3265.          HOLD = .FALSE.
  3266.          RETURN
  3267.       END IF
  3268.       IF (JPMC1(NPE2(2),JSTR2,0,CSTR2,0) .EQ. -3) THEN
  3269.          HOLD = .FALSE.
  3270.          RETURN
  3271.       END IF
  3272.  
  3273. C Same J for both DOs?
  3274.       IF (EQUAL(JSTR1,JSTR2) .EQ. -3) THEN
  3275.          HOLD = .FALSE.
  3276.          RETURN
  3277.       END IF
  3278.  
  3279. C c2 = c1+1?
  3280.       NUM1 = 1
  3281.       VAL1 = CTOI(CSTR1,NUM1)
  3282.       NUM1 = 1
  3283.       VAL2 = CTOI(CSTR2,NUM1)
  3284.       IF (VAL2 .NE. (VAL1+1)) THEN
  3285.          HOLD = .FALSE.
  3286.          RETURN
  3287.       END IF
  3288.  
  3289. C Every statement in the range of the first DO an assignment?
  3290.       POINTR = FIRST(1)
  3291. 30      CONTINUE
  3292.       IF (NODETP(POINTR) .NE. 49) THEN
  3293.          HOLD = .FALSE.
  3294.          RETURN
  3295.       END IF
  3296.       IF (POINTR .NE. LAST(1)) THEN
  3297.          POINTR = ZYNEXT(POINTR)
  3298.          GO TO 30
  3299.       END IF
  3300.  
  3301. C Conditions are met.  Peel the last iteration of the first DO to the
  3302. C tail of the DO resulting in intervening code.  Output the remaining DOs
  3303. C in the sequence unchanged.  This sets up the modified first DO and the
  3304. C immediately following statement for action by ICOD3 and then by PDOSEQ
  3305. C (E1,E2 equivalence).
  3306.       HOLD = .TRUE.
  3307.       CALL ZMESS(' Applying paradigm PJK.',2)
  3308.  
  3309. C Output comment that peeling being applied.
  3310.       CALL ZTOKWR(TCMMNT,LENGTH(COM),COM,TKNCHN)
  3311.  
  3312.  
  3313. C Output the DO statement with (J-c1)-1 replaced by (J-c2)-1.
  3314.  
  3315.       CALL GETIL(JUNK,TRMLBL)
  3316. C DO
  3317.         CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
  3318. C termination label reference
  3319.         CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
  3320. C DO variable
  3321.         CALL ZTOKWR(TNAME,LENGTH(VAR),VAR,TKNCHN)
  3322. C =
  3323.         CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
  3324. C 1
  3325.         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  3326. C ,
  3327.         CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  3328. C (
  3329.         CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  3330. C JSTR1
  3331.         CALL ZTOKWR(TNAME,LENGTH(JSTR1),JSTR1,TKNCHN)
  3332. C -
  3333.         CALL ZTOKWR(TMINUS,0,DUMMY(1),TKNCHN)
  3334. C CSTR2
  3335.         CALL ZTOKWR(TDCNST,LENGTH(CSTR2),CSTR2,TKNCHN)
  3336. C )
  3337.         CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  3338. C -
  3339.         CALL ZTOKWR(TMINUS,0,DUMMY(1),TKNCHN)
  3340. C 1
  3341.         CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  3342. C end-of-statement (DO)
  3343.         CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  3344.       SNUM = SNUM + 1
  3345.       CALL COMOUT(SNUM)
  3346.  
  3347. C Write the range of the first DO.
  3348.       POINTR = FIRST(1)
  3349. 700      CONTINUE
  3350.       CALL YSTMT(POINTR,TKNCHN)
  3351.       SNUM = SNUM + 1
  3352.       CALL COMOUT(SNUM)
  3353.       IF (POINTR .NE. LAST(1)) THEN
  3354.          POINTR = ZYNEXT(POINTR)
  3355.          GO TO 700
  3356.       END IF
  3357.  
  3358. C Write the terminating CONTINUE.
  3359. C Terminating label
  3360.       CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
  3361. C CONTINUE
  3362.       CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
  3363. C end-of-statement (CONTINUE statement)
  3364.       CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  3365.       SNUM = SNUM + 1
  3366.       CALL COMOUT(SNUM)
  3367.  
  3368. C Output the range of the first DO with (J-c1)-1 = J-c2 substituted
  3369. C for the DO variable.
  3370.       POINTR = FIRST(1)
  3371. 20      CONTINUE
  3372.         CALL UASGN(POINTR,VAR,JSTR1,CSTR2,-1,TKNCHN)
  3373.       IF (POINTR .NE. LAST(1)) THEN
  3374.          POINTR = ZYNEXT(POINTR)
  3375.          GO TO 20
  3376.       END IF
  3377.  
  3378. C Output the remaining DOs in the sequence.
  3379.       DO 800 I = 2,NRDOS
  3380.          POINTR = FIRST(I)
  3381.          CALL YSTMT(ZYPREV(POINTR),TKNCHN)
  3382.          SNUM = SNUM + 1
  3383.          CALL COMOUT(SNUM)
  3384. 900         CONTINUE
  3385.          CALL YSTMT(POINTR,TKNCHN)
  3386.          SNUM = SNUM + 1
  3387.          CALL COMOUT(SNUM)
  3388.          IF (POINTR .NE. LAST(I)) THEN
  3389.             POINTR = ZYNEXT(POINTR)
  3390.             GO TO 900
  3391.          END IF
  3392.          CALL YSTMT(ZYNEXT(POINTR),TKNCHN)
  3393.          SNUM = SNUM + 1
  3394.          CALL COMOUT(SNUM)
  3395. 800     CONTINUE
  3396.  
  3397.       NUML = SNUM
  3398.  
  3399. C Set flag for interation of ISTCD.
  3400.       ITERAT = .TRUE.
  3401.  
  3402.       END
  3403. C-----------------------   PDOSEQ.MAC
  3404. C ---------------------------------------------------------------------
  3405. C        P D O S E Q - Process DO sequence
  3406. C
  3407.        SUBROUTINE PDOSEQ(VAR,E1,E2,E3,FIRST,LAST,NRDOS,NUMF,NUML,
  3408.      +                    LSTOUT)
  3409.  
  3410.        INTEGER VAR(7),E1(50),E2(50),E3,FIRST(50),LAST(50),NRDOS,
  3411.      +          NUMF,NUML,LSTOUT
  3412.  
  3413.       COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  3414.       INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  3415.         SAVE
  3416. C---------------------------------------------------------
  3417. C    TOOLPACK/1    Release: 2.1
  3418. C---------------------------------------------------------
  3419. C
  3420. C THIS IS USED BY BOTH ISTSB AND ISTCD
  3421. C
  3422. C This COMMON block contains the logical variable ITERAT which is
  3423. C set to .TRUE. when a condition is encountered that implies that
  3424. C further processing is required on the parse tree obtained from
  3425. C the token stream output from the current run.  ZQUIT is called
  3426. C with condition 'repeat' if and only if ITERAT is .TRUE.
  3427. C
  3428. C This COMMON block contains the logical variables ITERAT and CYCLE.
  3429.  
  3430.       COMMON /REPEAT/ ITERAT,CYCLE
  3431.       LOGICAL ITERAT,CYCLE
  3432.  
  3433.        INTEGER I,TRMLBL(6),DUMMY(2),SNUM,POINTR,JUNK(7),
  3434.      +          CONST(1322),VCONST,NPE1(2),COM1(52),
  3435.      +          COM2(28),NUM1,CONONE(2),JSTR1(10),JSTR2(10),CSTR1(10),
  3436.      +          CSTR2(10),VAL1,VAL2,ADDSTR(10),VALADD,NUM4,NRDIGS,JUNK1,
  3437.      +          COM3(63),COM4(63),COM5(67)
  3438.  
  3439.        LOGICAL E1EQV,E2EQV,POSCON,HOLD
  3440.  
  3441.        INTEGER LENGTH,ZYNEXT,CTOI,NODETP,ZYDOWN,ZYPREV,ITOC,
  3442.      +          JPMC1,EQUAL,CHKDOP
  3443.  
  3444.        EXTERNAL GETIL,YEXPR,COMOUT,LENGTH,ZTOKWR,YSTMT,
  3445.      +           ZYNEXT,CHKEQV,CTOI,NODETP,GETSTR,ZYDOWN,ZYPREV,ITOC,
  3446.      +           JPMC1,EQUAL,UASGN,P4AJAK,CHKDOP
  3447.  
  3448. C---------------------------------------------------------
  3449. C    TOOLPACK/1    Release: 2.1
  3450. C---------------------------------------------------------
  3451. C
  3452. C  TKLAST = LAST TOKEN NUMBER
  3453. C
  3454.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  3455.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  3456.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  3457.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  3458.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  3459.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  3460.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  3461.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  3462.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  3463.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  3464.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  3465.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  3466.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  3467.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  3468.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  3469.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  3470.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  3471.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  3472.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  3473.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  3474.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  3475.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  3476.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  3477.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  3478.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  3479.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  3480.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  3481.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  3482.  
  3483.  
  3484. C "C*** DO loops condensed - E1 and E2 equivalence ***"
  3485.        DATA COM1/67,42,42,42,32,68,79,32,108,
  3486.      +            111,111,112,115,32,99,111,110,100,101,
  3487.      +            110,115,101,100,32,45,32,69,49,
  3488.      +            32,97,110,100,32,69,50,32,101,
  3489.      +            113,117,105,118,97,108,101,110,99,
  3490.      +            101,32,42,42,42,129/
  3491.  
  3492. C "C*** DO loops condensed ***"
  3493.        DATA COM2/67,42,42,42,32,68,79,32,108,
  3494.      +            111,111,112,115,32,99,111,110,100,101,
  3495.      +            110,115,101,100,32,42,42,42,129/
  3496.  
  3497. C "C*** WARNING: There should be no assignment statements between"
  3498.        DATA COM3/67,42,42,42,32,
  3499.      +            87,65,82,78,73,78,71,58,32,
  3500.      +            84,104,101,114,101,32,115,104,111,117,
  3501.      +            108,100,32,98,101,32,110,111,32,
  3502.      +            97,115,115,105,103,110,109,101,110,116,
  3503.      +            32,115,116,97,116,101,109,101,110,116,
  3504.      +            115,32,98,101,116,119,101,101,110,129/
  3505.  
  3506. C "C             above CONTINUE and first comment line of +'s ***"
  3507.        DATA COM4/67,32,32,32,32,32,32,
  3508.      +            32,32,32,32,32,32,32,
  3509.      +            97,98,111,118,101,32,67,79,78,84,
  3510.      +            73,78,85,69,32,97,110,100,32,
  3511.      +            102,105,114,115,116,32,99,111,109,109,
  3512.      +            101,110,116,32,108,105,110,101,32,
  3513.      +            111,102,32,43,39,115,32,42,
  3514.      +            42,42,129/
  3515.  
  3516. C "C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++"
  3517.        DATA COM5/67,43,43,43,43,43,
  3518.      +            43,43,43,43,43,43,43,43,43,43,
  3519.      +            43,43,43,43,43,43,43,43,43,43,
  3520.      +            43,43,43,43,43,43,43,43,43,43,
  3521.      +            43,43,43,43,43,43,43,43,43,43,
  3522.      +            43,43,43,43,43,43,43,43,43,43,
  3523.      +            43,43,43,43,43,43,43,43,43,43,
  3524.      +            129/
  3525.  
  3526.        DATA DUMMY(1)/129/
  3527.        DATA CONONE/49,129/
  3528.        SNUM = NUMF
  3529.  
  3530.        CALL CHKEQV(E1,E2,NRDOS,E1EQV,E2EQV)
  3531.        IF (E1EQV .AND. E2EQV) THEN
  3532.  
  3533. C The DOs are E1 and E2 equivalent.  Output comment.
  3534.           CALL ZTOKWR(TCMMNT,LENGTH(COM1),COM1,TKNCHN)
  3535.           CALL ZMESS('Paradigm PEQ.',2)
  3536.  
  3537. C Check the permutability condition. (Warnings may be issued as
  3538. C comments.)
  3539.           JUNK1 = CHKDOP(VAR,FIRST,LAST,NRDOS)
  3540.  
  3541. C The DO equivalent to the sequence has parameters E1,E2,E3 and its
  3542. C range is the concatenation of the ranges.  Write the equivalent DO.
  3543.  
  3544. C Generate the termination label.
  3545.           CALL GETIL(JUNK,TRMLBL)
  3546. C DO
  3547.            CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
  3548. C termination label reference
  3549.            CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
  3550. C DO variable
  3551.            CALL ZTOKWR(TNAME,LENGTH(VAR),VAR,TKNCHN)
  3552. C =
  3553.            CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
  3554. C E1
  3555.           CALL YEXPR(E1(1),TKNCHN)
  3556. C ,
  3557.            CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  3558. C E2
  3559.           CALL YEXPR(E2(1),TKNCHN)
  3560. C ,E3 if incrementation parameter not default
  3561.           IF (E3 .NE. 0) THEN
  3562.               CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  3563.              CALL YEXPR(E3,TKNCHN)
  3564.           END IF
  3565. C end-of-statement (modified DO)
  3566.            CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  3567.           SNUM = SNUM + 1
  3568.           CALL COMOUT(SNUM)
  3569. C Write the range (concatenation of the ranges).
  3570.           DO 200 I = 1,NRDOS
  3571.              POINTR = FIRST(I)
  3572. 300             CONTINUE
  3573.              CALL YSTMT(POINTR,TKNCHN)
  3574.              SNUM = SNUM + 1
  3575.              CALL COMOUT(SNUM)
  3576.              IF (POINTR .NE. LAST(I)) THEN
  3577.                 POINTR = ZYNEXT(POINTR)
  3578.                 GO TO 300
  3579.              END IF
  3580. 200        CONTINUE
  3581. C Write the terminating CONTINUE.
  3582. C Terminating label
  3583.           CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
  3584. C CONTINUE
  3585.           CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
  3586. C end-of-statement (CONTINUE statement)
  3587.           CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  3588.           SNUM = SNUM + 1
  3589.           CALL COMOUT(SNUM)
  3590.           NUML = SNUM + 2*(NRDOS - 1)
  3591.           LSTOUT = ZYNEXT(LAST(NRDOS))
  3592. C Set flag for iteration of ISTCD.
  3593.           ITERAT = .TRUE.
  3594.           RETURN
  3595.        END IF
  3596. C The DOs are not E1 and E2 equivalent.  Test the parameters of the
  3597. C first two DOs for the f01ak,f01al paradigms defined as follows:  The
  3598. C two DOs must be (1) E2 equivalent, (2) E3 default or 1, and (3) the
  3599. C first and second E1s have either of the following two corresponding
  3600. C forms:
  3601.  
  3602. C       (J+c1)+1, (J+(c2))+1
  3603. C or       (J-c1)+1, (J-(c2))+1
  3604.  
  3605. C for some J where where c1,c2 .ge. 0 and c2 .gt. c1.  If c1=0, the forms are
  3606.  
  3607. C       J+1,(J+c2)+1
  3608. C and       J+1,(J-c2)+1.
  3609.  
  3610. C Test the first two DOs in the sequence for E2 equivalence.
  3611.        CALL CHKEQV(E1,E2,2,E1EQV,E2EQV)
  3612.        IF (.NOT. E2EQV) GO TO 100
  3613. C The first two DOs are E2 equivalent.
  3614.        IF (E3 .NE. 0) THEN
  3615.           IF (NODETP(E3) .NE. 107) GO TO 100
  3616.           CALL GETSTR(E3,CONST)
  3617.           NUM1 = 1
  3618.           VCONST = CTOI(CONST,NUM1)
  3619.           IF (VCONST .NE. 1) GO TO 100
  3620.        END IF
  3621. C E3 is default or 1. Check the condition on the E1 nodes.
  3622. C Remove outer parenthesis for comparison.
  3623.        DO 400 I=1,2
  3624.           NPE1(I) = E1(I)
  3625. 1200          CONTINUE
  3626.           IF (NODETP(NPE1(I)) .EQ. 101) THEN
  3627.              NPE1(I) = ZYDOWN(NPE1(I))
  3628.              GO TO 1200
  3629.           END IF
  3630. 400       CONTINUE
  3631.  
  3632.        IF (JPMC1(NPE1(1),JSTR1,1,CSTR1,1) .EQ. -3) THEN
  3633.           POSCON = .FALSE.
  3634.           GO TO 2000
  3635.        END IF
  3636.        IF (JPMC1(NPE1(2),JSTR2,1,CSTR2,1) .EQ. -3) THEN
  3637.           POSCON = .FALSE.
  3638.           GO TO 2000
  3639.        END IF
  3640.  
  3641.        IF (EQUAL(JSTR1,JSTR2) .EQ. -3) THEN
  3642.           POSCON = .FALSE.
  3643.           GO TO 2000
  3644.        END IF
  3645.  
  3646.        NUM1 = 1
  3647.        VAL1 = CTOI(CSTR1,NUM1)
  3648.        NUM1 = 1
  3649.        VAL2 = CTOI(CSTR2,NUM1)
  3650.        IF (VAL2 .LE. VAL1) THEN
  3651.           POSCON = .FALSE.
  3652.           GO TO 2000
  3653.        END IF
  3654.  
  3655.        POSCON = .TRUE.
  3656.        GO TO 2100
  3657.  
  3658. 2000       CONTINUE
  3659.        IF (JPMC1(NPE1(1),JSTR1,0,CSTR1,1) .EQ. -3) GO TO 100
  3660.  
  3661.        IF (JPMC1(NPE1(2),JSTR2,0,CSTR2,1) .EQ. -3) GO TO 100
  3662.  
  3663.        IF (EQUAL(JSTR1,JSTR2) .EQ. -3) GO TO 100
  3664.  
  3665.        NUM1 = 1
  3666.        VAL1 = CTOI(CSTR1,NUM1)
  3667.        NUM1 = 1
  3668.        VAL2 = CTOI(CSTR2,NUM1)
  3669.        IF (VAL2 .LE. VAL1) GO TO 100
  3670.  
  3671. 2100   CONTINUE
  3672. C Conditions for one of the paradigms are met.
  3673. C Output comment that condensation being applied.
  3674.        CALL ZTOKWR(TCMMNT,LENGTH(COM2),COM2,TKNCHN)
  3675.        IF (POSCON) THEN
  3676.           CALL ZMESS('Paradigm PAK.',2)
  3677.        ELSE
  3678.           CALL ZMESS('Paradigm PAL.',2)
  3679.        END IF
  3680.  
  3681. C The "clean-up" is the range of one of the DOs (depending on which case
  3682. C holds) replicated c2-c1 times with an appropriate substitution.  If the
  3683. C f01ak case holds (POSCON = .TRUE.) the transformed code sequence is
  3684. C clean-up, condensed DOs, remaining DOs.  LSTOUT is then the terminating
  3685. C statement of the last DO, i.e., ZYNEXT(LAST(NRDOS)).  In the f01al
  3686. C case, the sequence is condensed DOs, remaining DOs, any assignment
  3687. C statements following the last DO, clean-up.  LSTOUT is the last
  3688. C assignment statement in sequence output after the DO.
  3689.  
  3690.        IF (POSCON) THEN
  3691. C The range of the first DO is output with the DO variable
  3692. C replaced by J+(c1+1),...,J+(c2)
  3693.           VALADD = VAL1 + 1
  3694.           NUM4 = 4
  3695.           NRDIGS = ITOC(VALADD,ADDSTR,NUM4)
  3696. 2300          CONTINUE
  3697.           POINTR = FIRST(1)
  3698. 1100          CONTINUE
  3699.           CALL UASGN(POINTR,VAR,JSTR1,ADDSTR,0,TKNCHN)
  3700.           IF (POINTR .NE. LAST(1)) THEN
  3701.              POINTR = ZYNEXT(POINTR)
  3702.              GO TO 1100
  3703.           END IF
  3704.           IF (VALADD .NE. VAL2) THEN
  3705.              VALADD = VALADD + 1
  3706.              NUM4 = 4
  3707.              NRDIGS = ITOC(VALADD,ADDSTR,NUM4)
  3708.              GO TO 2300
  3709.           END IF
  3710.        END IF
  3711.  
  3712. C Output the DO statement.
  3713.  
  3714.        CALL GETIL(JUNK,TRMLBL)
  3715. C DO
  3716.         CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
  3717. C termination label reference
  3718.         CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
  3719. C DO variable
  3720.         CALL ZTOKWR(TNAME,LENGTH(VAR),VAR,TKNCHN)
  3721. C =
  3722.         CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
  3723.        IF (POSCON) THEN
  3724. C (
  3725.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  3726. C JSTR1
  3727.            CALL ZTOKWR(TNAME,LENGTH(JSTR1),JSTR1,TKNCHN)
  3728. C +
  3729.            CALL ZTOKWR(TPLUS,0,DUMMY(1),TKNCHN)
  3730. C CSTR2
  3731.            CALL ZTOKWR(TDCNST,LENGTH(CSTR2),CSTR2,TKNCHN)
  3732. C )
  3733.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  3734. C +
  3735.            CALL ZTOKWR(TPLUS,0,DUMMY(1),TKNCHN)
  3736. C 1
  3737.            CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  3738.        ELSE
  3739. C (
  3740.            CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
  3741. C JSTR
  3742.            CALL ZTOKWR(TNAME,LENGTH(JSTR1),JSTR1,TKNCHN)
  3743. C -
  3744.            CALL ZTOKWR(TMINUS,0,DUMMY(1),TKNCHN)
  3745. C CSTR1
  3746.            CALL ZTOKWR(TDCNST,LENGTH(CSTR1),CSTR1,TKNCHN)
  3747. C )
  3748.            CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
  3749. C +
  3750.            CALL ZTOKWR(TPLUS,0,DUMMY(1),TKNCHN)
  3751. C 1
  3752.            CALL ZTOKWR(TDCNST,LENGTH(CONONE),CONONE,TKNCHN)
  3753.        END IF
  3754. C ,
  3755.         CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
  3756. C xpr(E2(1))
  3757.        CALL YEXPR(E2(1),TKNCHN)
  3758. C end-of-statement (DO)
  3759.         CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  3760.  
  3761. C Write the concatenation of the ranges of the DOs.
  3762.        DO 600 I = 1,2
  3763.           SNUM = SNUM + I
  3764.           POINTR = FIRST(I)
  3765. 700          CONTINUE
  3766.           CALL YSTMT(POINTR,TKNCHN)
  3767.           SNUM = SNUM + 1
  3768.           CALL COMOUT(SNUM)
  3769.           IF (POINTR .NE. LAST(I)) THEN
  3770.              POINTR = ZYNEXT(POINTR)
  3771.              GO TO 700
  3772.           END IF
  3773. 600       CONTINUE
  3774. C Write the terminating CONTINUE.
  3775. C Terminating label
  3776.        CALL ZTOKWR(TDCNST,LENGTH(TRMLBL),TRMLBL,TKNCHN)
  3777. C CONTINUE
  3778.        CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
  3779. C end-of-statement (CONTINUE statement)
  3780.        CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
  3781.        SNUM = SNUM + 1
  3782.        CALL COMOUT(SNUM)
  3783. C Output the remaining DOs in the sequence.
  3784.        DO 800 I = 3,NRDOS
  3785.           POINTR = FIRST(I)
  3786.           CALL YSTMT(ZYPREV(POINTR),TKNCHN)
  3787.           SNUM = SNUM + 1
  3788.           CALL COMOUT(SNUM)
  3789. 900          CONTINUE
  3790.           CALL YSTMT(POINTR,TKNCHN)
  3791.           SNUM = SNUM + 1
  3792.           CALL COMOUT(SNUM)
  3793.           IF (POINTR .NE. LAST(I)) THEN
  3794.              POINTR = ZYNEXT(POINTR)
  3795.              GO TO 900
  3796.           END IF
  3797.           CALL YSTMT(ZYNEXT(POINTR),TKNCHN)
  3798.           SNUM = SNUM + 1
  3799.           CALL COMOUT(SNUM)
  3800. 800     CONTINUE
  3801.  
  3802.        IF (POSCON) THEN
  3803.           LSTOUT = ZYNEXT(LAST(NRDOS))
  3804.        ELSE
  3805. C f01al paradigm is matched.  Output a comment line of +'s and a
  3806. C warning, followed by the assignment sequence that trails the last DO.
  3807.           CALL ZTOKWR(TCMMNT,LENGTH(COM5),COM5,TKNCHN)
  3808.           CALL ZTOKWR(TCMMNT,LENGTH(COM3),COM3,TKNCHN)
  3809.           CALL ZTOKWR(TCMMNT,LENGTH(COM4),COM4,TKNCHN)
  3810.  
  3811.           POINTR = ZYNEXT(ZYNEXT(LAST(NRDOS)))
  3812. 3000          CONTINUE
  3813.           IF (NODETP(POINTR) .EQ. 49) THEN
  3814.              CALL YSTMT(POINTR,TKNCHN)
  3815.              SNUM = SNUM + 1
  3816.              CALL COMOUT(SNUM)
  3817.              POINTR = ZYNEXT(POINTR)
  3818.              GO TO 3000
  3819.           ELSE
  3820. C Assignments following the last DO have been output.
  3821.              LSTOUT = ZYPREV(POINTR)
  3822.  
  3823. C The range of the second DO is output with the DO variable
  3824. C replaced by J-(c2-1),...J-c1.
  3825.  
  3826.              VALADD = VAL2 - 1
  3827.              NUM4 = 4
  3828.              NRDIGS = ITOC(VALADD,ADDSTR,NUM4)
  3829. 2400             CONTINUE
  3830.              POINTR = FIRST(2)
  3831. 500             CONTINUE
  3832.              CALL UASGN(POINTR,VAR,JSTR1,ADDSTR,-1,TKNCHN)
  3833.              IF (POINTR .NE. LAST(2)) THEN
  3834.                 POINTR = ZYNEXT(POINTR)
  3835.                 GO TO 500
  3836.              END IF
  3837.              IF (VALADD .NE. VAL1) THEN
  3838.                 VALADD = VALADD - 1
  3839.                 NUM4 = 4
  3840.                 NRDIGS = ITOC(VALADD,ADDSTR,NUM4)
  3841.                 GO TO 2400
  3842.              END IF
  3843.           END IF
  3844.        END IF
  3845.  
  3846.        NUML = SNUM
  3847.  
  3848. C Set flag for interation of ISTCD.
  3849.        ITERAT = .TRUE.
  3850.        RETURN
  3851.  
  3852. 100       CONTINUE
  3853.        LSTOUT = ZYNEXT(LAST(NRDOS))
  3854.  
  3855. C At least one condition for f01al,f01ak paradigms is violated.
  3856. C Check conditions for the f04aj,f04ak paradigm.  If the necessary
  3857. C conditions hold, peel as described in comments in P4AJAK.
  3858.        HOLD = .FALSE.
  3859.        CALL P4AJAK(VAR,E1,E2,E3,FIRST,LAST,NRDOS,SNUM,NUML,HOLD)
  3860.        IF (HOLD) THEN
  3861.           RETURN
  3862.        ELSE
  3863. C Invoke the general case.
  3864.           CALL ZMESS('General Case Invoked.',2)
  3865.           CALL GENOUT(VAR,E1,E2,E3,FIRST,LAST,NRDOS,SNUM,NUML)
  3866.        END IF
  3867.  
  3868.        END
  3869. C-----------------------   PROPU.MAC
  3870. C ----------------------------------------------------------------------
  3871. C
  3872. C       P R O P U   -   Process Program-Unit
  3873. C
  3874.  
  3875.         SUBROUTINE PROPU(PUROOT)
  3876.         INTEGER PUROOT
  3877.  
  3878.         INTEGER SPTR,DOPTR,SNUM,DOVAR(7),E1(50),E2(50),E3,FIRST(50),
  3879.      +          LAST(50),TYPE,NUMF,NUML,NRDOS,REFNOD,VARNOD,ASNBUF(200),
  3880.      +          NRAB,LSTOUT
  3881.       LOGICAL SIC
  3882.  
  3883.         COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  3884.         INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  3885.         SAVE
  3886. C---------------------------------------------------------
  3887. C    TOOLPACK/1    Release: 2.1
  3888. C---------------------------------------------------------
  3889. C
  3890. C THIS IS USED BY BOTH ISTSB AND ISTCD
  3891. C
  3892. C This COMMON block contains the logical variable ITERAT which is
  3893. C set to .TRUE. when a condition is encountered that implies that
  3894. C further processing is required on the parse tree obtained from
  3895. C the token stream output from the current run.  ZQUIT is called
  3896. C with condition 'repeat' if and only if ITERAT is .TRUE.
  3897. C
  3898. C This COMMON block contains the logical variables ITERAT and CYCLE.
  3899.  
  3900.       COMMON /REPEAT/ ITERAT,CYCLE
  3901.       LOGICAL ITERAT,CYCLE
  3902.  
  3903.         INTEGER ZYDOWN,ZYNEXT,LENGTH,NODETP,COMPAR,E3EQV,I,NXTNOD
  3904.         EXTERNAL ZYDOWN,ZYNEXT,LENGTH,ZTOKWR,NODETP,DOPROP,PDOSEQ,
  3905.      +           COMPAR,YSTMT,E3EQV,ICOD1,ICOD2,ICOD3
  3906.  
  3907.         SAVE
  3908.  
  3909.         DATA SNUM/1/
  3910.  
  3911.         SPTR=ZYDOWN(PUROOT)
  3912.       NRAB = 0
  3913.  
  3914. 100      CONTINUE
  3915.       TYPE = NODETP(SPTR)
  3916.       DOPTR = SPTR
  3917.       NRDOS = 0
  3918.  
  3919. C If the statement is a DO, get its properties.
  3920.       IF (TYPE .EQ. 61) THEN
  3921.  
  3922. C Get the DO variable node for possible use in processing the
  3923. C intervening code paradigms.
  3924.          REFNOD = ZYDOWN(DOPTR)
  3925.          IF (NODETP(REFNOD) .EQ. 115) REFNOD = ZYNEXT(REFNOD)
  3926.          VARNOD = ZYDOWN(ZYNEXT(REFNOD))
  3927. 300         CONTINUE
  3928.          NRDOS = NRDOS + 1
  3929.          CALL DOPROP(DOPTR,DOVAR,E1(NRDOS),E2(NRDOS),E3,
  3930.      +                 FIRST(NRDOS),LAST(NRDOS))
  3931.          DOPTR = ZYNEXT(ZYNEXT(LAST(NRDOS)))
  3932.          IF (NODETP(DOPTR) .EQ. 61) THEN
  3933. C Another DO.  If it is E3-equivalent to the preceding DO, include
  3934. C it in the sequence.
  3935.             IF (E3EQV(DOPTR,E3,DOVAR) .EQ. -2) GO TO 300
  3936.          END IF
  3937.  
  3938. C We are at the end of the sequence of E3-equivalent DOs.
  3939.          IF (NRDOS .EQ. 1) THEN
  3940. C Only one DO in the sequence.  Look for intervening code paradigms.
  3941.             SIC = .FALSE.
  3942.             NUMF = SNUM
  3943.  
  3944. C f01ad paradigm.
  3945.             CALL ICOD2(VARNOD,E1(1),E2(1),E3,FIRST(1),LAST(1),
  3946.      +                    NUMF,NUML,ASNBUF(1),NRAB,SIC)
  3947.             IF (SIC) THEN
  3948. C Peeling for f01ad paradigm took place.  Advance the pointers
  3949. C accordingly, output the remainder of the program unit without change.
  3950. C and return.
  3951.                SNUM = NUML
  3952.                SPTR = ZYNEXT(ZYNEXT(LAST(1)))
  3953. 30               CONTINUE
  3954.                CALL YSTMT(SPTR,TKNCHN)
  3955.                SNUM = SNUM + 1
  3956.                CALL COMOUT(SNUM)
  3957.                SPTR = ZYNEXT(SPTR)
  3958.                IF (SPTR .NE. 0) GO TO 30
  3959.                RETURN
  3960.             END IF
  3961.  
  3962. C f01ad paradigm did not match.  Output the assignment buffer.
  3963.             DO 500 I = 1,NRAB
  3964.                  CALL YSTMT(ASNBUF(I),TKNCHN)
  3965.                SNUM = SNUM + 1
  3966.                CALL COMOUT(SNUM)
  3967. 500            CONTINUE
  3968.             NRAB = 0
  3969.  
  3970. C Check for the f04aj,f04ak pattern emitted from P4AJAK.
  3971.             NXTNOD = 0
  3972.             NUMF = SNUM
  3973.             CALL ICOD3(VARNOD,E1(1),E2(1),E3,FIRST(1),LAST(1),
  3974.      +                    NUMF,NUML,NXTNOD)
  3975.  
  3976.             IF (NXTNOD .NE. 0) THEN
  3977. C f04aj,f04ak statement movement and E1,E2 equivalence condensation
  3978. C took place.  Advance the pointers accordingly, output the remainder
  3979. C of the program unit without change and return.
  3980.                SNUM = NUML
  3981.                SPTR = NXTNOD
  3982. 50               CONTINUE
  3983.                CALL YSTMT(SPTR,TKNCHN)
  3984.                SNUM = SNUM + 1
  3985.                CALL COMOUT(SNUM)
  3986.                SPTR = ZYNEXT(SPTR)
  3987.                IF (SPTR .NE. 0) GO TO 50
  3988.                RETURN
  3989.             END IF
  3990.  
  3991. C Try the f01ae,f01af paradigms.
  3992. C Note: SIC = .FALSE.
  3993.             NUMF = SNUM
  3994.             CALL ICOD1(VARNOD,E1(1),E2(1),E3,FIRST(1),LAST(1),
  3995.      +                    NUMF,NUML,SIC)
  3996.             IF (SIC) THEN
  3997. C Peeling for paradigm f01ae or f01af took place.  Advance the
  3998. C pointers accordingly and proceed.
  3999.                SNUM = NUML
  4000.                SPTR = ZYNEXT(ZYNEXT(LAST(1)))
  4001.                SNUM = SNUM + 1
  4002.                CALL COMOUT(SNUM)
  4003.             ELSE
  4004. C Intervening code paradigms do not match. Output the DO statement
  4005. C and proceed.
  4006.                  CALL YSTMT(SPTR,TKNCHN)
  4007.                SNUM = SNUM + 1
  4008.                CALL COMOUT(SNUM)
  4009.             END IF
  4010.          ELSE
  4011. C The DO sequence contains more than one member.
  4012. C Output the assignment buffer.
  4013.             DO 600 I = 1,NRAB
  4014.                  CALL YSTMT(ASNBUF(I),TKNCHN)
  4015.                SNUM = SNUM + 1
  4016.                CALL COMOUT(SNUM)
  4017. 600            CONTINUE
  4018.             NRAB = 0
  4019.  
  4020.             NUMF = SNUM
  4021.             CALL PDOSEQ(DOVAR,E1,E2,E3,FIRST,LAST,NRDOS,NUMF,NUML,
  4022.      +                    LSTOUT)
  4023.             SNUM = NUML
  4024.             SPTR = LSTOUT
  4025.             GO TO 200
  4026.          END IF
  4027.       ELSE
  4028. C Statement is not a DO.  If it is an assignment statement place it
  4029. C in the assignment buffer.
  4030.          IF (NODETP(SPTR) .EQ. 49) THEN
  4031.             NRAB = NRAB + 1
  4032.             IF (NRAB .GT. 200) CALL ERROR ('ISTCD: Dimension Of '
  4033.      +            //'ASNBUF Too Small.')
  4034.             ASNBUF(NRAB) = SPTR
  4035.          ELSE
  4036. C Statement is neither an assignment nor a DO.  Output the assignment
  4037. C buffer and the statement.
  4038.             DO 400 I = 1,NRAB
  4039.                  CALL YSTMT(ASNBUF(I),TKNCHN)
  4040.                SNUM = SNUM + 1
  4041.                CALL COMOUT(SNUM)
  4042. 400            CONTINUE
  4043.             NRAB = 0
  4044.               CALL YSTMT(SPTR,TKNCHN)
  4045.             SNUM = SNUM + 1
  4046.             CALL COMOUT(SNUM)
  4047.          END IF
  4048.       END IF
  4049.  
  4050. C Look for the next statement.
  4051. 200     SPTR=ZYNEXT(SPTR)
  4052.         IF (SPTR.NE.0) GO TO 100
  4053.  
  4054.         END
  4055.